Anzeige
Archiv - Navigation
1520to1524
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Gültigkeitsliste und Speichern "mögen" sich nicht

Gültigkeitsliste und Speichern "mögen" sich nicht
29.10.2016 08:56:22
Oberschlumpf
Hallo Leute!
Ich beiß mir schon seit vielen Tagen die Zähne aus :-/
Hier schon mal eine Bsp-Datei:
https://www.herber.de/bbs/user/109082.zip
Die Excel-Datei ist größer als 300kb, deswegen ZIP.
Also...
In den Spalten A + B gibt es 25.000 Einträge (im Original fast 90.000).
Die Spalten sind nach Spalte A sortiert.
So seht ihr gleich, dass die ersten 3 Einträge in A die gleichen Einträge sind.
Dann gibt es noch Spalte F.
- diese Spalte ist nicht sortiert
- es gibt nur 8 doppelte Einträge (was auch so gewollt ist)
- sehr viele Einträge in Spalte F gibt es auch in Spalte A
Das Ziel ist nun:
Für jeden Eintrag in F, der in A vorhanden ist, sollen die unterschiedlichen Einträge aus B in G (gleiche Zeile wie F) "zusammengefasst" werden.
Bsp:
aus diesen Einträgen (Spalten A + B)
Userbild
soll das hier werden (rot markiert)
Userbild
Der Code funktioniert einwandfrei...eigentlich^^
Das "tut" der Code:
1. Zuerst werden die Bereiche A1:B25000 und F1:F1117 jeder für sich an eine Array-Variable übergeben
2. Es wird eine For/Next-Schleife mit den 25.000 Einträgen gestartet
3. Innerhalb der 1. Schleife wird eine weitere For/Next-Schleife mit den 1117 Einträgen gestartet
4. Innerhalb der 2. Schleife wird jeder der 1117 Einträge in den 25.000 Einträgen gesucht
5. Wenn gefunden, werden die Einträge aus Spalte B in Spalte G "zusammengetragen"; durch Kommata getrennt
6. Wenn die Suche fertig ist, werden die Einträge in Spalte G in eine Gültigkeitsliste umgewandelt
7. Nun wird noch überprüft, ob bestimmte Einträge in den Zellen in Spalte G vorhanden sind. Wenn ja, wird die Zellenhintergrundfarbe grün gefärbt.
8. Zum Schluß wird noch in jeder Zelle in Spalte G nur der erste Wert der Gültigkeitsliste angezeigt
Bis hier hin funktioniert alles ganz genau so wie von mir gewünscht.
Wenn ich nun aber die Datei speicher, sie schließe und wieder öffne, dann erscheint diese Meldung:
Userbild
Und ich weiß nicht, warum!!!!!!!!!!
Klicke ich auf "Nein" wird die Datei natürlich nicht geöffnet.
Klicke ich auf "Ja", sind in Spalte G die Gültigkeitslisten verschwunden, und es steht nur der jeweils erste Wert in den Zellen in Spalte G.
Ich würde mich echt sehr freuen!, wenn mir das bitte jemand erklären kann, und wenn mir ein Code gezeigt wird, der dieses Problem löst.
Ich bedanke mich schon mal für eure Mühen.
Ciao
Thorsten

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Gültigkeitsliste und Speichern "mögen" sich nicht
29.10.2016 09:13:02
silex1
Hallo Thorsten,
dieser Fehler tritt meist zw. verschiedenen XL-Versionen auf. Ich hab dies Problem mit xl07 zu xl10-13.
Dies ist ein Bug, der bis heute nicht behoben wurde mMn. Beim Speichern werden in der Gültigkeit die ; durch ein Komma ersetzt und beim Öffnen zerhaut es dann die Gültigkeit.
Abhilfe schafft da bei mir immer die Auflistung aller Bedingungen im Blatt und dann mit nem NAMEN arbeiten.
VG René
AW: Gültigkeitsliste und Speichern "mögen" sich nicht
29.10.2016 09:17:48
Oberschlumpf
Hallo René,
und vielen Dank erst mal!
Ich hatte echt viel recherchiert, aber von einem Bug hatte ich nix gelesen...mist.
Ich werd mal mit meinem Kollegen reden, für den das sein soll.
Vielleicht finden wir ja eine Lösung mit verteckten Hilfsspalten oder so.
Ich lass noch offen, weil...wer weiß...vielleicht...und so :-)
Ciao
Thorsten
Anzeige
Optimierung
29.10.2016 20:54:45
Michael
Hi zusammen,
solche Schleifen kann ich gar nicht sehen, ohne aufzumucken...
Ich bitte, meine Laufvariable "i" nicht als Kritik an Deiner "standardmäßigen" Notation aufzufassen; ebenso möchte ich aber nicht wegen "i" statt "ldbIdxMain" kritisiert werden.
Für Laufvariablen würde ich ausschließlich Long verwenden, da Berechnungen mit double immer langsamer sind; außerdem gibt es keine 1,5-te Schleife.
Ansonsten ist die optimierte Variante um einen Faktor 150 schneller:
Option Explicit
Sub sbStartM()
Dim larMain() As Variant, ldbIdxMain As Double, ldbTest As Double
Dim objD As Object, i&, s$
' & = as long, $ = as string; s nur, um einmal Lcase einzusparen
Dim t0 As Single
t0 = Timer
larMain = Range("A1:B25000")
Set objD = CreateObject("scripting.dictionary")
For i = 1 To UBound(larMain)
s = LCase(larMain(i, 1))
'   Dieser Code macht nur "," zwischen Begriffen, ohne das letzte...
'      If objD.exists(s) Then
'         objD(s) = objD(larMain(i)) & "," & larMain(i, 2)
'        Else
'         objD(s) = larMain(i, 2)
'      End If
'   Aber wenn ein "," als letztes im Originalcode steht,
'   wird es noch einfacher:
objD(s) = objD(s) & larMain(i, 2) & ","
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
MsgBox (Timer - t0) * 1000  ' ca. Faktor 150 schneller!
'    sbValidation
End Sub
Sub sbStart()
Dim larMain() As Variant, larOther As Variant, ldbIdxMain As Double, ldbIdxOther As Double,  _
ldbTest As Double
Dim t0 As Single
t0 = Timer
larMain = Range("A1:B25000")
larOther = Range("F1:F1117")
If Range("G1").Value  "" Then
Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Columns("G:G").ColumnWidth = 24
For ldbIdxMain = 1 To UBound(larMain)
For ldbIdxOther = 1 To UBound(larOther)
If LCase(larMain(ldbIdxMain, 1)) = LCase(larOther(ldbIdxOther, 1)) Then
Range("G" & ldbIdxOther).Value = Range("G" & ldbIdxOther).Value &  _
larMain(ldbIdxMain, 2) & ","
End If
ldbTest = ldbTest + 1
Next
DoEvents
Next
'    sbValidation
MsgBox (Timer - t0) * 1000
End Sub
... und könnte, wenn man das Array global definiert, in der zweiten Sub verwendet werden zur Überprüfung nach ="", so daß hier zumindest keine außer den unbedingt notwendigen Tabellenzugriffe erfolgen.
Schöne Grüße,
Michael
Anzeige
erratum
29.10.2016 21:01:18
Michael
Im auskommentierten Code der 1. Schleife muß es statt
objD(s) = objD(larMain(i)) & "," & larMain(i, 2)

natürlich
objD(s) = objD(s) & "," & larMain(i, 2)

heißen.
AW: erratum
30.10.2016 00:53:52
Oberschlumpf
Hi Michael,
danke für deine Ideen.
Da ich es auf Anhieb noch nicht erkenne, frage ich dich einfach mal:
Ist denn nun auch dieser von René erwähnte BUG kein Problem mehr?
Wenn deine Optimierung "nur" daher rührt, weil es dir in den Fingern juckte, weil ich zu umständlich programmierte :-), dann trotzdem auch dafür danke.
Ciao
Thorsten
Anzeige
Optimierung? Aber soooo was von!!!!
30.10.2016 09:26:45
Oberschlumpf
Hi Michael,
JA, dein Code ist aber so was von Optimierung! :-)
Ich hab ihn nun mal in meiner Bsp-Datei eingebaut, getestet, und (für meine Verhältnisse) als genial empfunden, was den Zeitunterschied betrifft! :-)
die Timer-Ergebnisse sehen so aus:

Dein Code:    859,357
Mein Code: 114859,400
Der Unterschied ist....HAMMER!! :-)
Danke schön.
Und ich werde, nein, ich muss deine Optimierung irgdwie als Referenz für mich so speichern, dass ich sie schnell finde, wenn ich sie mal wieder benötige :-)
Ciao
Thorsten
Nachtrag! :-)
30.10.2016 10:51:35
Oberschlumpf
Hallo noch mal :-)
Hab nun deine Optimierung in die Originaldatei eingebaut.
Und du ahnst es bestimmt schon :-)
Aus vorher
00:01:46
sind nun
00:00:05
geworden! :-)
Und das geht noch schneller!
Ich hatte wegen der fast 2 Minuten eine Progressbar eingebaut.
Und damit man diese wenigstens ein bisschen sehen kann :-), musste ich DoEvents verwenden.
DENN OHNE DoEvents BENÖTIGT DEIN CODE NUUUUUR
00:00:01 !!!!!!
Das ist echt der Wahnsinn, Michael! :-)
(und ich glaube, mein VBA = gut sollt ich vielleicht wieder auf ... = ein bisschen gut ...oder so ändern^^ :-)
Danke noch mal!
Ciao
Thorsten
Anzeige
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
Anzeige
doch noch ne Feinheit
30.10.2016 18:24:21
Michael
Viele mögen ja keine globalen Variablen, ich finde sie aber in Fällen wie diesen ganz nützlich - das spart Einiges an interner Datenschaufelei: zumindest bei byVal wird eine komplette Kopie erzeugt: wozu? Global wird immer auf ein und demselben Datenbestand gearbeitet.
Allerdings: man sollte vielleicht am Ende der 2. Prozedur Sub sbValidationV0() den verwendeten Datenbereich wieder freigeben; also larMain="" oder empty oder so (und beim Dim die Klammern weglassen?).
Gruß,
M.
AW: doch noch ne Feinheit
30.10.2016 18:30:42
Oberschlumpf
Hi Michael,
erst mal: Echt vielen Dank für deine ausführliche Erklärung.
Da gibt es für mich so Einiges mehr zu verstehen.
Dafür brauche ich aber n bisschen Zeit :-)
Hiermit wollte ich nur die Info geben, dass auch ich weiter am Ball bin.
Ciao erst mal
Thorsten
Anzeige
dann bis in Kürze,
30.10.2016 19:23:24
Michael
Thorsten,
ich habe die Geschichte ja auch nicht in 5 Minuten erstellt...
Grüße zurück,
Michael

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige