Das Forum ist für zuviel Dank gesperrt1. :-D
Also hier was mit Kommentaren. Da ich nicht wußte, wie fit du in VBA bist habe ich mal alles kommentiert. Also deshalb nicht wundern / böse sein. Die Teile die du kennst, einfach überspringen. In der Funktion habe ich die Variablennamen nochmal geändert . Wenn Fragen sind, einfach nochmal antworten. VG
Sub gütligkeit()
Dim gültigliste As String
Dim i As Long
Dim letzte As Long
With Sheets("Analysedaten")
'Anfangswert der Liste, "," ist nötig um jeden Wert mit Kommas eingeschlossen zuhaben, so kann man vermeiden, dass man bei der
' Suche, ob der Wert schon da ist bspw. 2 auch in 32 findet - womit die Zahl nicht aufgenommen würde
gültigliste = ","
'soll ausschließlich nur SPALTE A betrachten
'letzer Eintrag in Spalte A
letzte = .Cells(Rows.Count, 1).End(xlUp).Row
'alle Zeilen in Spalte A ab Zeiel 2 durchgehen
For i = 2 To letzte
'wenn der WErt nicht leer ist und es sich um eine Zahl handel - IsNumeric -, weiterprüfen
If .Cells(i, 1) <> "" And IsNumeric(.Cells(i, 1)) Then
'die Werte werden in einem String aneinandergereit. jeder Wert ist von Kommas eingeschlossen,
'deshalb mit instr prüfen ob es das Gebilde ,ZellWert, gibt. Wenn es da gibt, wird die Stelle im String angezeigt
' ist der Wert > 0 würde der Eintrag dort beginng, bei 0 wurde er nicht gefunden
' wenn also 0 dan eintragen. Dazu ans Ende des String packen und mit einem "," abschließen, um den WErt eindeutig zu finden
If InStr(1, gültigliste, "," & .Cells(i, 1) & ",", vbTextCompare) = 0 Then gültigliste = gültigliste & CLng(.Cells(i, 1)) & ","
End If
Next i
End With
'wenn nur eine Komma drin ist, wurde nichts gefunden, ergänzt dann nix machen
If gültigliste <> "," Then
'die Liste beginnt mit "," und endet mit ",", die wieder wegmachen, als nur den String ab Stelle 2 bis vorletzte Stelle (Länge -ersten - letzen = Lönge -2) kopieren
gültigliste = Mid(gültigliste, 2, Len(gültigliste) - 2)
'die LIste so jetzt über einen Algorithmus sorteieren lassen, dazu wird er an die Funktion übergeben und kommt sortiert zurück
gültigliste = BubbleSort(gültigliste)
'nun die alte Gültigkeit löschen und die neue einfügen
With Sheets("Tabelle2").Range("G5").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=gültigliste
End With
End If
End Sub
' das ist einer von vielen Sortieralgorythmen, ggf. mal im Internet schauen, gibt auch noch andere und schnellere, für deinen Zweck reicht der aber aus
' Bei Bubblesort wird eine Array mit Wert sortiert. Dabei werden immer zwei benachbarte Arrayglieder verglichen und wenn der erste größer ist vertausch.
' Das ganze läuft in vielen Schleifen, bis bei einem Durchgang kein Vertauschung mehr notwendig war - ergo die Liste sortiert ist.
Function BubbleSort(Liste As Variant)
Dim i As Long, stellen As Long, Temp As Long
Dim sortiert As Boolean
Dim Listearray
'habe die Namen nochmal geändert, um es verständliche rzu amchen
'zu Anfang wird die übergebene Liste in ein Array aufgesplittet, die Liste kommt aus dem Funktinsnamen und ist der Wert den wir da oben übergeben haben
' das aufsaplten passiert an den Stellen, wo ein Komma ist
Listearray = Split(Liste, ",")
' schauen, wie wiele Glieder es dann im Array gibt
stellen = UBound(Listearray)
' jetzt mit einer Schleife durchgehen, do loop hat untenbei until ein Abbruchkriterium - sortiert ist wahr, es werden erst die Anweisungen nach dem do
' ausgeführt und dann sortiert geprüft, ist sortiert falsch, werden die Anweisungen nochmal durchgeführt, so lange bis sortiert wahr ist
Do
' anfangs das Abbruchkriterium auf wahr setzen, wird nur, wenn wir Stellen vertauschen wieder auf nein gesetzt
sortiert = True
' jetzt in einer for schleife die Elemente vergleichen. Ein array starte beim Index 0 deshalb bei 0 beginnen. Vergleich bis 1 Stelle weniger als die
' Gesamtstellenzahl. Man braucht ja nur soviel Vergleiche wie "Lücken" zwischen den Werten sind. bspw. 2 3 4 , sind 3 zahlen aber nur 2 Lücken also 2 Vergleiche
For i = 0 To stellen - 1
' jetzt zwei aufeinanderfolgende Elemente vergleichen, Clng interpretiert das als Zahl vom Typ long, wenn nicht wird die Liste als String (ist ja einer)
'interpretiert und es kommt die verquere Sortierung wie beim ersten post
If CLng(Listearray(i)) > CLng(Listearray(i + 1)) Then
' wenn der Wert größer ist tuaschen, dazu erst die erste Zelle in einem Temp Variable schreiben,
Temp = CLng(Listearray(i))
' dann den Wert von der zweiten Zellen in die erste Zellen
Listearray(i) = CLng(Listearray(i + 1))
' in die zweite Zelle den wert aus Temp
Listearray(i + 1) = Temp
' jetzt sind die Werte getauscht, und da was getauscht wurden, das Abbruchkriterium auf falsch setzen, könne ja noch was zu, Sortieren geben
sortiert = False
End If
Next i
'jetzt prfen und entweder beenden oder nochmal schauen
' bei einem Durchlauf wo nix mehr vertauscht wurde, bleibt sortiert wahr und damit bricht die Schleife ab
Loop Until sortiert
' jetzt wieder das Array als Liste zusammenpacken, dazu die einzelnen Elemente mit einem Komma verketten - braucht die Gültigkeit ja so.
ergebnis = Join(Listearray, ",")
' nun haben wir wieder unsere Liste aber sortiert, die geben wir an das aufrufende Programm zurück
BubbleSort = ergebnis
End Function
|