PDA

Vollständige Version anzeigen : "Intelligente" Textanalyse


ebs17
13.10.2009, 14:26
Es gibt eine Reihe von Aufgaben, da stößt die Anwendung und Kombination von VBA-Standardfunktionen (Left, Right, Mid, Instr, InstrRev, Split) an Grenzen, insbesondere wenn die zu analysierenden Textstellen variabel sind und sich nur schwer bis gar nicht in (herkömmliche) Regeln fassen lassen. An der Stelle oder schon deutlich vorher könnte man sich "regulärer Ausdrücke" bedienen.

Reguläre Ausdrücke (Regular Expressions) haben ihren Urspung in Perl (Webprogrammierung), sind aber auch auf einem normalen Officerechner und somit in Access einsetzbar. Die notwendige Bibliothek Microsoft VBScript Regular Expressions 5.5 (vbscript.dll) sollte i.d.R. vorhanden sein.
Mit regulären Ausdrücken kann man komplexe bis unmögliche Codekonstruktionen durch ein (teilweise anspruchsvolles) Suchmuster und einen sonst einfachen Ablauf ersetzen.

Beispiele:
Einfache Ersetzung/Filterung
Public Function fChangeText(sText As String) As String
Dim Regex As Object
Set Regex = CreateObject("Vbscript.Regexp")
With Regex

.Pattern = "\D" ' löscht alles außer Ziffern

'.Pattern = "[^0-9,]" ' löscht alles außer Ziffern und Komma
'.Pattern = "[^a-zA-ZäöüßÄÖÜ]" ' löscht alles außer Buchstaben

.Global = True ' Jedes Auftreten wird berücksichtigt
fChangeText = .Replace(sText, "")
End With
Set Regex = Nothing
End Function

Debug.Print fChangeText("Ich möchte nur die Ziffern aus 12-4.56/444.5 haben.")
-> "124564445"


Erkennen (und Ersetzen) von kombinierten Ausdrücken
Public Function fEntferneZeitangabe(sText As String, sFehltext As String) As String
Dim RegEx
Set RegEx = CreateObject("Vbscript.regexp")
With RegEx
.Pattern = " [0-9]+ " & sFehltext
.Global = False 'Nur das Erste Auftreten wird berücksichtigt
fEntferneZeitangabe = .Replace(sText, "")
End With
End Function

Debug.Print fEntferneZeitangabe("Neues aus der Anstalt vom 27.1.2009 - Kabarett 145 min.avi", "min")
-> "Neues aus der Anstalt vom 27.1.2009 - Kabarett.avi"

Bei der oftmaligen Wiederholung der Funktionen (Verwendung in Abfragen und Schleifen) wie oben gezeigt sollte man das Initialisieren der Objektvariable Regex aus der Funktion herausnehmen und einmalig vor Aufruf der Funktion vornehmen (sonst spürbare Performancebremse).


Finden von Mailadressen in einem Text. Einige zusätzliche Informationen können nebenbei ausgewertet werden.
Public cMatches As Object
Public m As Object
Public oRegEx As Object

Sub aufruf()
Set oRegEx = CreateObject("Vbscript.regexp")
Call fFindMailAdresses("webmäster@aßpheute.de = Email Adresse! " & _
"a@b.c = Keine Email Adresse! " & _
"master@the.universe = Email Adresse!, " & _
"Max Mustermann M.M.treffer@heute.de, Susi Seelig Susi-S-Treff@hopp.com")

Debug.Print "Treffer: " & cMatches.Count
For Each m In cMatches
Debug.Print m.Value & ";" & m.FirstIndex & ";" & m.Length
Debug.Print m.SubMatches.Count & "--" & m.SubMatches(0) & "--" & _
m.SubMatches(1) & "--" & m.SubMatches(2)
Next
Set m = Nothing
Set cMatches = Nothing
Set oRegEx = Nothing
End Sub

Public Sub fFindMailAdresses(sText As String)
'// Die erzeugte MatchCollection enthält identifizierte Mailadressen,
'// deren (0-basierte) Startposition im Text sowie deren Länge aus einem
'// vorgegebenen Text. Durch die Wiederholung eines gleichen (geklammerten)
'// Teilsuchmusters kann eine gefundene Mailadresse gleich zerlegt werden
'// (Alias, Domainname, Topleveldomain).

With oRegEx
' Suchmuster
.Pattern = "(\w[\wÄÖÜäöüß\.-]+)@(\w[\wÄÖÜäöüß\.-]+)\.(\w[\wÄÖÜäöüß\.-]+)"
' Alle oder nur erste Textstelle berücksichtigen
.Global = True
' Treffer in MatchCollection eintragen
Set cMatches = .Execute(sText)
End With

End Sub

Viel Spaß beim Ausprobieren.

ebs17
13.10.2009, 18:21
Nachtrag: Wer eigene Suchmuster zusammenstellen will und sonstige Informationen benötigt, findet hier weitere Hinweise:
http://www.aspheute.com/artikel/20000829.htm
http://de.selfhtml.org/perl/sprache/regexpr.htm

Sascha Trowitzsch
23.10.2009, 13:26
Bei den Links sollte vielleicht noch der zur Referenz zum MS-RegExpr-Objekts nicht fehlen:

http://msdn.microsoft.com/en-us/library/yab2dx62%28VS.85%29.aspx
Mehr dazu:
http://msdn.microsoft.com/en-us/library/6wzad2b2%28VS.85%29.aspx

Ciao, Sascha

ebs17
15.03.2010, 15:19
Eine zusätzliche Anwendungsvariante:
- Mittels Barodescanner werden Einlieferungsnummern erfasst.
- Dabei haben diese Nummern je Dienstleister eine unterschiedliche Struktur, z.B. Dienstleister1 zwei Großbuchstaben und dann neun Ziffern, Dienstleister2 13 Ziffern
- An Hand der Einlieferungsnummer soll der Dienstleister ermittelt werden.
Public Function fTest_Dienstleister(ByVal sText As String) As String
Dim RegEx As Object
Dim vArr As Variant
Dim i As Long
fTest_Dienstleister = ""
vArr = Array("Dienstleister1", "[A-Z]{2}[0-9]{9}", _
"Dienstleister2", "[0-9]{13}")
Set RegEx = CreateObject("Vbscript.Regexp")
With RegEx
For i = 0 To UBound(vArr) Step 2
.Pattern = vArr(i + 1)
.Global = False
If .test(sText) Then
fTest_Dienstleister = vArr(i)
Exit For
End If
Next
End With
Set RegEx = Nothing
End Function

ebs17
04.05.2010, 11:28
Kleine Anreicherung: Mit Trim, LTrim und RTrim kann man äußere Leerzeichen entfernen. Eine gleichartige Funktion, die auch andere Zeichen oder sogar Zeichenketten entfernt, könnte so aussehen:
Public Function fSpecialTrim(ByVal sText As String, ByVal sDelimiter As String, _
Optional ByVal bRight As Boolean = True) As String
Dim RegEx As Object
Set RegEx = CreateObject("Vbscript.Regexp")
With RegEx
If bRight Then
.Pattern = "[" & sDelimiter & "]+$"
Else
.Pattern = "^[" & sDelimiter & "]+"
End If
.Global = True
fSpecialTrim = .Replace(sText, "")
End With
Set RegEx = Nothing
End Function

' Aufruf links Glätten
?fSpecialTrim("%X%%X%%X%StringA%X%StringB%X%StringC%X%%X%%X%", "%X%", False)
-> StringA%X%StringB%X%StringC%X%%X%%X%

' Aufruf rechs Glätten
?fSpecialTrim("%X%%X%%X%StringA%X%StringB%X%StringC%X%%X%%X%", "%X%", True)
-> %X%%X%%X%StringA%X%StringB%X%StringC

ebs17
09.01.2011, 23:55
An dieser Stelle möchte ich einen Link ergänzen:
Acc2003 - Komma durch Komma mit Leerzeichen

Hier wird sehr schön gezeigt, wie man bei der Replace-Methode Teile des Suchmusters (Pattern) als Bestandteil des Ersetzungsmusters verwenden kann.

ebs17
21.05.2011, 16:18
Eine weitere Linkergänzung:
VBA - Codeoptimierung For Next Schleife

Hier zeigt ransi, wie man ermitteln kann, ob ein Wort, das Bestandteil einer vorgegebenen Liste ist, in einem zu durchsuchenden String enthalten ist (mit Rückgabe dieses Wortes).

ebs17
02.06.2012, 17:35
Jürgen Auer hat auf seiner Seite Sql-und-Xml (http://www.sql-und-xml.de/) eine Vielzahl von Informationen inklusive theoretischem Unterbau bereitgestellt:
Reguläre Ausdrücke - einen Text nach komplexen Ausdrücken durchsuchen (http://www.sql-und-xml.de/regex/)

ebs17
20.10.2012, 00:08
Nachfolgend sind einige Hilfsfunktionen, die jeweils eine Methode eines RegEx-Objektes kapseln und so für verschiedenste Anwendungsformen wie z.B. Abfragen, Schleifen und natürlich auch Einzelaufrufe anbieten.
Die vorangestellte Property stellt ein RegEx-Objekt zur Verfügung, auf das dann ständig zugegriffen werden kann. Damit erzielt man u.a. Performancevorteile gegenüber der Variante, dass man dieses Objekt in einer Funktion erzeugt und diese Objekterzeugung pro Funktionsaufruf wiederholt würde.
Private pRegEx As Object

Public Property Get oRegEx() As Object
If (pRegEx Is Nothing) Then Set pRegEx = CreateObject("Vbscript.Regexp")
Set oRegEx = pRegEx
End Property

Public Function RegExTest(ByVal SourceText As String, _
ByVal SearchPattern As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As Boolean

With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.Multiline = bMultiLine
RegExTest = .Test(SourceText)
End With
End Function

Public Function RegExReplace(ByVal SourceText As String, _
ByVal SearchPattern As String, _
ByVal ReplaceText As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As String

With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.Multiline = bMultiLine
RegExReplace = .Replace(SourceText, ReplaceText)
End With
End Function

Public Function RegExMatchCollection(ByVal SourceText As String, _
ByVal SearchPattern As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As Object

With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.Multiline = bMultiLine
Set RegExMatchCollection = .Execute(SourceText)
End With
End Function
RegExTest:
Hier wird einfach getestet, ob das Suchmuster (Pattern) im zu analysierenden Text vorkommt.
Beispiel: Es gibt einen zu testenden Artikel "Pullover Rot". Jetzt soll getestet werden, ob er einer der Wahlfarben rot, blau oder gelb entspricht.
Aufruf:
Sub aufruf_RegExTest()
Dim Teststring As String
Teststring = "Pullover Rot"

If RegExTest(Teststring, " (rot|blau|gelb)$", False) Then
Debug.Print "Treffer"
Else
Debug.Print "no"
End If
End Sub
Mit dem dritten (farbig hervorgehobenen) Parameter kann man z.B. steuern, ob man das Ignorieren der Groß-/Kleinschreibung berücksichtigen will oder nicht.

RegExReplace:
Das Ersetzen erfolgt recht ähnlich zu der Replace-Methode von VBA, ist allerdings um einiges variabler und differenzierter.
Beispiel: In einem Text will man ein Wort ersetzen. Das VBA-Replace ersetzt alle gefundenen Zeichenfolgen ohne Rücksicht darauf, ob die Zeichenfolge ein eigenes Wort oder nur Teil eines Wortes ist. RegEx kann da unterscheiden.
Aufruf:
Sub aufruf_RegExReplace()
Dim Textstring As String
Textstring = "Es ist super, von einem Superhirn zu profitieren."

Textstring = RegExReplace(Textstring, "\bsuper\b", "gigantisch")
Debug.Print Textstring
End Sub

RegExMatchCollection:
Die Methode Execute erzeugt eine Matchcollection (Auflistung von Treffern). Dabei ist eine solche Matchcollection etwas anderes als eine VBA.Collection. Zur Auswertung einer Matchcollection muss man eine zusätzliche Funktion aufsetzen, die dann auswählt, welche der vielen Informationen der Matchcollection (Anzahl der Treffer, Trefferauflistung, einige Zusatzangaben zu Treffern wie Länge und Startposition im Text, Teiltreffer bei Subpattern) weiterverwendet werden sollen und wie die Ausgabe bzw. Nutzung der Ergebnisse erfolgen soll.
Beispiel: Ein zu analysierender Text enthält Teilinformationen. Für einen weiteren Text, der die Teilinformationen semikolongetrennt enthält, soll ermittelt werden, wieviele übereinstimmende Teilinformationen zum anderen Text bestehen, um z.B. eine Ähnlichkeit quantifizieren zu können.
Aufruf:
Sub AnzahlUebereinstimmungen()
Dim sToFind As String
Dim sFindIn As String
sFindIn = "AX1;AX5 CX3,BX4;GH7-HZ4"
sToFind = "AX1;AX5;CX3;DX8"

Debug.Print CountOccur(sToFind, sFindIn)
End Sub

Public Function CountOccur(ByVal ToFind As String, FindIn As String) As Long
Dim oMC As Object
Dim sResPattern As String
sResPattern = "(" & Join(Split(ToFind, ";"), "|") & ")"
Set oMC = RegExMatchCollection(FindIn, sResPattern)
CountOccur = oMC.Count
Set oMC = Nothing
End Function

habibi246
02.12.2013, 13:48
Danke Euch Allen! Hat Mir Sehr Geholfen!!!!

Forza SGD
19.08.2016, 13:53
Sehr hilfreich - Besten Dank!

halweg
11.11.2016, 14:00
Ich wärme das Thema mal wieder auf in der Hoffnung, dass die Knowhow-Träger noch mitlesen.

Also inzwischen arbeite ich oft und erfolgreich mit den regulären Ausdrücken in VBA.
Eine Sache ist mir jedoch bisher nicht gelungen: Wenn ich mit einer regulären Suche eine bestimmte Textstelle im Dokument suche, z. B. überSet folgen = RegExMatch_Collection(ActiveDocument.Content, "Anhang") bekomme ich diesen Text im Dokument nicht gefunden (also z. B. markiert). So was wie selection.start = folgen(0).FirstIndex
selection.End = folgen(0).FirstIndex + 20funktioniert also nicht, da im Dokument hinsichtlich der Markierung offensichtlich verborgende Texte mitgezählt werden, die an RegExMatch_Collection nicht übergeben werden.

Konkret will ich eine Auflistung der Seitennummern erstellen, wo ein bestimmter regulärer Ausdruck gefunden wurde.
Geht das überhaupt?
Vielen Dank im Voraus!

ebs17
11.11.2016, 14:33
Detail- und andere Probleme bespricht man besser nicht in diesem Archiv-Thema, sondern in einem eigenem Thema in einem geeigneten Forum, dann gerne auch mit einem Beispieldokument.

Nur kurz: In der Matchcollection werden nur Treffer auf das Suchmuster gesammelt. Also müsste man an der Stelle prüfen, ob da auch wirklich von Dir erwartete Treffer erscheinen. Gibt es Treffer, kann man auch FirstIndex (0-basiert Position des ersten Zeichens im nachgefragten Text) und Length (Länge des Treffers) ableiten.
Textmarkierungen dürften dann ein Wordproblem sein.

halweg
12.11.2016, 11:46
Danke für die Rückmeldung, Eberhard
Bin deinem Rat gefolgt, bitte schau mal unter http://www.ms-office-forum.net/forum/showthread.php?p=1772364