Schnelles Vergleichen mit Dictionary
19.01.2017 18:20:22
Michael
Hi,
anbei Testdatei: der 1. Button erzeugt Testwerte ...
a) für die Masterliste und
b) für die importierte Liste
Sub testWerte()
Dim a$(), b$(), i&, j&, r&, s$
Const Mu = 5, Mo = 8 ' Anzahl Zeichen Masterliste von-bis
Const Zu = 65, Zo = 125 ' Nr. des Zeichens von-bis
Const Lu = 1, Lo = 3500 ' Anzahl Werte Masterliste von-bis
Const Iu = 1, Io = 350 ' Anzahl Werte Import von-bis
ReDim a(Lu To Lo, 1 To 1)
ReDim b(Iu To Io, 1 To 1)
Randomize
For i = Lu To Lo
r = WorksheetFunction.RandBetween(Mu, Mo)
For j = 1 To r
a(i, 1) = a(i, 1) & Chr(WorksheetFunction.RandBetween(Zu, Zo))
Next
Next
For i = 1 To Int(Lo / 10) ' paar Werte durch "ähnliche" ersetzen
r = WorksheetFunction.RandBetween(Lu, Lo - 3)
s = a(r, 1)
For j = 0 To 2
a(r + j, 1) = s & Chr(WorksheetFunction.RandBetween(Zu, Zo))
Next
Next
Sheets("Masterliste").Range("A2:A100000").ClearContents
Sheets("Masterliste").Range("A2").Resize(UBound(a)) = a
For i = Iu To Io
r = WorksheetFunction.RandBetween(Mu, Mo)
For j = 1 To r
b(i, 1) = b(i, 1) & Chr(WorksheetFunction.RandBetween(Zu, Zo))
Next
r = WorksheetFunction.RandBetween(Iu, Io)
b(i, 1) = b(i, 1) & a(r, 1)
r = WorksheetFunction.RandBetween(Mu, Mo)
For j = 1 To r
b(i, 1) = b(i, 1) & Chr(WorksheetFunction.RandBetween(Zu, Zo))
Next
Next
Sheets("Import").Range("A2:A100000").ClearContents
Sheets("Import").Range("A2").Resize(UBound(b)) = b
End Sub
Der zweite Button wertet sie aus und schreibt das Ergebnis in Spalte B (Import-Blatt):
Sub vglWerte()
Dim a, b, lb&, i&, j&, k&, p&, s$, o As Object, oi, ois
Dim ok As Boolean
Const ml = 5 ' minimale Länge in Masterliste, je höher, desto fixer
Dim t0 As Single
t0 = Timer
Set o = CreateObject("scripting.dictionary")
a = Sheets("Masterliste").Range("A1").CurrentRegion
Sheets("Import").Range("B:B").ClearContents
b = Sheets("Import").Range("A1").CurrentRegion
For i = 2 To UBound(a)
s = Left(a(i, 1), ml)
If o(s) = "" Then
' o(s) = "|" & a(i, 1)
o(s) = Chr(0) & a(i, 1)
Else
If InStr(2, o(s), a(i, 1), vbBinaryCompare) = 0 Then _
o(s) = o(s) & Chr(0) & a(i, 1)
End If
Next
'Stop
For i = 2 To UBound(b)
ok = False
lb = Len(b(i, 1))
For j = 1 To lb ' im Prinzip nur bis lb-ml+1
s = Mid(b(i, 1), j, ml)
If o.exists(s) Then
' Stop
ois = Split(o(s), Chr(0))
For k = 1 To UBound(ois)
p = InStr(2, b(i, 1), ois(k), vbBinaryCompare)
If p > 0 Then b(i, 1) = ois(k): ok = True: Exit For
Next
End If
If ok Then Exit For
Next
Next
Sheets("Import").Range("B1").Resize(UBound(b)) = b
Sheets("Import").Range("G5").Value = UBound(b) - 1 & " aus " & _
UBound(a) - 1 & " in " & (Timer - t0) * 1000 & " ms."
End Sub
Die Datei: https://www.herber.de/bbs/user/110723.xlsm
Die Idee ist, die Mindestzeichenlänge der Masterliste (Const ml = 5) in ein Dictionary einzulesen und dort alle Varianten zwischenzuspeichern, also:
- in der ML existieren z.B. die drei Begriffe: Auto_Benz, Auto_Opel und Auto_Ford; der "Key" im Dict. heißt nun (ml=5!): "Auto_".
- "unter" diesem Key werden alle Varianten als String erfaßt, also die 3 wie oben.
- der importierte Liste wird in "ml-Zeichen-Blöcken" durchsucht, und sobald so ein Teilstring im Dict. vorhanden ist, wird mit allen dort hinterlegten Varianten verglichen.
Beispiel: A2 = "Mein Auto_Benz fährt subba."
Vergleiche der Reihe nach: "Mein ", "ein A", "in Au", "n Aut", " Auto" und "Auto_" - was im Dict. steht; die drei im Dict gespeicherten Begriffe werden dann in A2 gesucht, und "Auto_Benz" wird als Treffer in Spalte B übernommen.
Zunächst hatte ich als Trennzeichen zwischen den Begriffen ein "|", was aber zu Fehlfunktionen führte, weil es auch im Text vorhanden war: deshalb der Um- bzw. Ausweg über chr(0): dafür gibt es kein Zeichen, also kann es grundsätzlich in *keinem* Text vorkommen.
So: mit 350 aus 3500 ML: paar Millisekunden; mit 1000 aus 35.000 wenig mehr; bei meiner Hardware weniger als 1/5 Sekunden.
Happy Exceling,
Michael (excelerated)