freut mich, und zur eigent. Frage...
30.10.2016 18:13:38
Michael
Hi Thorsten,
ich erkläre mal kurz, wie das zustande kommt: die ursprünglichen Schleifen werden ja so x mal 10 hoch 5 mal y mal 10 hoch 4 mal durchlaufen, das macht also x mal y mal 10 hoch 9, also je nach x und y, mindestens 1 Mrd. Durchläufe. Das IST happig.
Ein Sortieralgo wie Bubblesort arbeitet erst mal ähnlich (auf EINE Liste bezogen), aber bei diesen Datenmengen geht er halt dann auch schwer in die Knie.
Den eigentlich Kick gibt das Dictionary: das ist vergleichbar mit einer Index-Datei bei einer Datenbank: die Schleifen sind in etwa vergleichbar mit einer Volltextsuche in der Datenbank - die dauert - während der Zugriff über den Index mit irgendwelchen Algorithmen (Bäume, Netze o.ä.) so optimiert ist, daß die POSITION des gesuchten Datensatzes durch eine minimale Anzahl von Entscheidungen ermittelt wird.
Genaugenommen hätte ich, anstatt
- das 2. Array wegzulassen und das 1. mit den Daten aus Spalte F zu überschreiben, das 1. Array erhalten können und
- anstatt die Werte aus Spalte B nur die jeweilige Zeilennr. im 1. Array (die "POSITION") ins Dictionary übernehmen können - das wäre vielleicht noch einen Ticken schneller gewesen.
Sei's drum: in solchen Fällen bietet es sich an, Daten, nach denen (oft) gesucht werden soll, ins Dictionary zu stecken, weil das eben den "indexmäßigen" Zugriff bietet, der rasend schnell ist.
Zum Thema: http://www.snb-vba.eu/VBA_Dictionary_en.html
Mit dem eigentlichen Problem habe ich gestern einige Zeit herumgespielt. Paar Gedanken:
- ich vermute, das Verschieben der Spalte G hattest Du nur zu Testzwecken während der Entwicklung eingebaut: stimmt das?
- die Gültigkeitsprüfung übersteht auch bei mir (nachvollziehbar) das Speichern nicht. Also: wie wäre es, sie komplett vor dem Speichern zu entfernen und beim Öffnen wieder aufzusetzen?
Wenn der Algo so schnell ist, sollte der Anwender doch damit leben können?
Man müßte (ist das so?) nur sicherstellen, daß bereits vom Anwender (in der Combobox) geänderte Werte nicht überschrieben werden.
Die Frage ist nur: will man den Lauf komplett machen oder speichert man NUR die wirklich nötigen Angaben? Z.B. in einem versteckten Extrablatt oder sonstwie...
Wenn ich das richtig überblicke, kommt ja auch Karins Lösung nicht ohne irgendwo zwischengespeicherte Werte aus: aber wenn man sie schon speichert, kann man ja auch wieder die Gültigkeitsprüfung aufsetzen.
So, jetzt:
1. Zwei Varianten (...V0 und ...V1) zum Testen, die V0 ist schneller (beachte das globale Array):
Option Explicit
Dim larMain() As Variant
Sub sbStartV0()
Dim objD As Object, i&, s$ ' & = as long, $ = as string; s nur, um einmal Lcase einzusparen
Dim t0 As Single, t1 As Single
t0 = Timer
larMain = Range("A1:B25000")
Set objD = CreateObject("scripting.dictionary")
For i = 1 To UBound(larMain)
s = LCase(larMain(i, 1))
objD(s) = objD(s) & larMain(i, 2) & ","
Next
' Der Geschwindigkeitsvorteil hier wird durch die Überprüfung nach "," in sbValidationV0
' NICHT aufgebraucht: DIESE Variante ist also vorzuziehen.
If Range("G1").Value "" Then
Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Columns("G:G").ColumnWidth = 24
larMain = Range("F1:F1117")
For i = 1 To UBound(larMain)
s = LCase(larMain(i, 1))
If objD.exists(s) Then larMain(i, 1) = objD(s) Else larMain(i, 1) = ""
Next
Range("g1").Resize(UBound(larMain), 1) = larMain
t1 = Timer
sbValidationV0
MsgBox "Schritt 1: " & (t1 - t0) * 1000 & " 2: " & (Timer - t1) * 1000
End Sub
Sub sbValidationV0()
Dim i&, a, aa&, s$
' a= array für split, aa=ubound(a), s = larmain(i,1), das schreibt sich schöner
Range("G:G").Validation.Delete ' alle fort, die evtl. da sind
For i = 1 To UBound(larMain)
' If i = 10 Then Stop
If larMain(i, 1) "" Then
s = larMain(i, 1)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1) ' analog Deinem Code: geht sehr fix
a = Split(s, ",")
aa = UBound(a)
If aa > 0 Then ' falls nur 1 Begriff, ist nichts zu tun...
With Range("G" & i)
With .Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=s
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
s = LCase(s)
If InStr(s, "java 8 update 51") > 0 And _
InStr(s, "java 8 update 51 (64-bit)") > 0 And _
InStr(s, "java 8.51 registry configuration 1.0") > 0 And _
aa = 2 Then
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
.Value = a(0)
End With
Else ' doch, sonst bleibt der EINE Begriff mit "," stehen.
Range("G" & i).Value = s ' da ist das "," abgeschnitten
End If
End If
Next
End Sub
Sub sbStartV1()
Dim objD As Object, i&, s$
' & = as long, $ = as string; s nur, um einmal Lcase einzusparen
Dim t0 As Single, t1 As Single
t0 = Timer
larMain = Range("A1:B25000")
Set objD = CreateObject("scripting.dictionary")
' hier die Variant "mit ohne" Komma am Ende, dann muß es hinterher nicht wieder entfernen
' dadurch wird der Dictionary-Zugriff eine Ecke Ticken langsamer - also bitte V0 verwenden!
For i = 1 To UBound(larMain)
s = LCase(larMain(i, 1))
If objD.exists(s) Then
objD(s) = objD(s) & "," & larMain(i, 2)
Else
objD(s) = larMain(i, 2)
End If
Next
If Range("G1").Value "" Then
Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Columns("G:G").ColumnWidth = 24
larMain = Range("F1:F1117")
For i = 1 To UBound(larMain)
s = LCase(larMain(i, 1))
If objD.exists(s) Then larMain(i, 1) = objD(s) Else larMain(i, 1) = ""
Next
Range("g1").Resize(UBound(larMain), 1) = larMain
t1 = Timer
sbValidationV1
MsgBox "Schritt 1: " & (t1 - t0) * 1000 & " 2: " & (Timer - t1) * 1000
End Sub
Sub sbValidationV1()
Dim i&, a, aa&, s$
' a= array für split, aa=ubound(a), s = larmain(i,1), das schreibt sich schöner
Range("G:G").Validation.Delete ' alle fort, die evtl. da sind
For i = 1 To UBound(larMain)
If larMain(i, 1) "" Then
a = Split(larMain(i, 1), ",")
s = LCase(larMain(i, 1))
aa = UBound(a)
If aa > 0 Then ' falls nur 1 Begriff, ist nichts zu tun...
With Range("G" & i)
With .Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=s
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
If InStr(s, "java 8 update 51") > 0 And _
InStr(s, "java 8 update 51 (64-bit)") > 0 And _
InStr(s, "java 8.51 registry configuration 1.0") > 0 And _
aa = 2 Then
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
.Value = a(0)
End With
End If
End If
Next
End Sub
und 2. ein Lösungsvorschlag zum "Retten" der Gültigkeitsprüfung übers Speichern hinweg; vorm Speichern Sub ValidWegspeichern(), beim Öffnen Sub ValidWiederRein(). Ausgewählte Werte in Spalte G werden dabei nicht geändert:
Option Explicit
Sub ValidEntf()
Cells.Validation.Delete ' alle fort, die evtl. da sind
End Sub
Sub ValidWiederRein()
Dim s$, t0 As Single, a, az&, i&, fs$, aSp ' fs=FormelString, aSp = split(a)
t0 = Timer
a = Sheets(2).Range("A1").CurrentRegion
If IsArray(a) Then
If UBound(a, 2) = 2 And UBound(a) > 1 Then
Cells.Validation.Delete ' löscht aber in ALLEN Spalten
For az = 1 To UBound(a)
aSp = Split(a(az, 2), ",")
fs = Replace(a(az, 1), ";", ",")
For i = 0 To UBound(aSp) - 1 ' -1 wegen des "," am Ende
With Range("G" & aSp(i)).Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=fs
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
' ob es eigentlich die ganzen Parameter braucht?
' Die sind doch std-mäßig vorbelegt...
Next
' MsgBox "!" & aSp(UBound(aSp)) & "!" ' siehst?
Next
MsgBox "Anzahl eingebaute Valid. " & az - 1 & vbLf & _
"Zeit = " & (Timer - t0) * 1000
End If
End If
End Sub
Sub ValidWegspeichern()
Dim r As Range, c As Range, objD As Object, oi, oa&, s$, t0 As Single, a, az&
' oi=Variant als dict-item, oa=Anzahl dict-Einträge, a=Array für Ausgabe
' az=long=zeile im Array a
On Error Resume Next
Set r = Cells.SpecialCells(xlCellTypeAllValidation)
If Err.Number 0 Then MsgBox "keine Valid.": Exit Sub
On Error GoTo 0
t0 = Timer
Set r = Intersect(r, Range("G:G"))
If Not r Is Nothing Then
Set objD = CreateObject("scripting.dictionary")
For Each c In r
s = c.Validation.Formula1
objD(s) = objD(s) & c.Row & ","
Next
' key = String bzw. Formel der Validation,
' item = Nr. der Zeile, in der die Validation steht
oa = objD.Count
ReDim a(oa, 1) ' je ab 0
For Each oi In objD.keys
a(az, 0) = oi
a(az, 1) = objD(oi)
az = az + 1
Next
Sheets(2).Range("A1").Resize(oa + 1, 2) = a
' hier sieht man im Prinzip den Excel-Fehler:
' zugewiesen wurden die Valids mit "," getrennt,
' ausgelesen werden sie aber mit ";"
MsgBox "Anzahl Valid. ges.: " & r.Count & vbLf & _
"davon eindeutige: " & oa & vbLf & _
"Zeit = " & (Timer - t0) * 1000
Else
MsgBox "keine Valid. in G": Exit Sub
End If
End Sub
Beim Wegspeichern stellt sich heraus, daß es (in der Beispieldatei) nämlich nur 33 verschiedene GPs gibt; die sind schnell ausgelesen (paar ms) und etwas langsamer zurück geschrieben.
Viel Spaß beim Testen und Gruß,
Michael