Scripting Dictionary Demo
27.02.2017 14:12:38
Michael
Hi,
Dir ist schon bewußt, daß mehrfache Werte vom Dictionary glattgebügelt werden?
Anbei ein Demo, das zu jedem Wert einen String mitführt, mit den Zellen (des Arrays in Spalte/Zeile, beginnend ab 1,1, egal, woher das Array gelesen wird) nämlich, die den Begriff enthalten.
Die erzeugten Testdaten enthalten im Schnitt 25% Leerstrings, so daß die Ausgabe für "" sehr lang ist: derart lange Strings kann VBA handeln, beim Schreiben ins Blatt wird er ab 1000nochwas Zeichen abgeschnitten.
Das Makro:
Option Explicit
Const sMax = 44, zMax = 114
Sub wegMit()
Sheets("Daten").Cells.Clear
Sheets("Ergebnis").Cells.Clear
Range("H4") = "Testwerte gelöscht"
Range("H5") = ""
End Sub
Sub WerteErzeugen()
Dim s&, z&, rMax&, r&, a
Sheets("Ergebnis").Cells.Clear
a = Sheets("Ergebnis").Range("A1").Resize(zMax, sMax)
Randomize
For s = 1 To sMax
For z = 1 To zMax
rMax = WorksheetFunction.RandBetween(0, 3)
For r = 1 To rMax
a(z, s) = a(z, s) & Chr(WorksheetFunction.RandBetween(65, 90))
Next
Next
Next
Sheets("Daten").Range("A1").Resize(zMax, sMax) = a
Range("H4") = "Testwerte erzeugt"
Range("H5") = ""
End Sub
Sub DicEinlesen()
Dim o As Object, oW, a, s&, z&
If Range("H4") "Testwerte erzeugt" Then MsgBox "keine Werte": Exit Sub
Set o = CreateObject("scripting.dictionary")
a = Sheets("Daten").Range("A1").Resize(zMax, sMax)
For s = 1 To sMax
For z = 1 To zMax
o(a(z, s)) = o(a(z, s)) & "|" & s & "," & z
Next
Next
' damit sind alle mehrfachen Begriffe eindeutig erfaßt und stecken in o (Dict. )
' a ist damit erledigt und kann für die Ausgabe verwendet werden:
ReDim a(1 To o.Count, 1 To 2)
z = 0
For Each oW In o.keys
z = z + 1
a(z, 1) = oW
a(z, 2) = o(oW)
Next
Set o = Nothing
Sheets("Ergebnis").Range("A1").Resize(z, 2) = a
Range("H4") = z & " Werte im Dictionary"
Range("H5") = "aus " & sMax * zMax & " Werten gesamt."
End Sub
Die Datei: https://www.herber.de/bbs/user/111798.xlsm
Schöne Grüße,
Michael