VBA Sortiermechanismus
26.03.2024 12:12:45
velo
ich habe mit einer Power Query mehrere Dateien in eine Tabelle ("PQ") zusammengefasst.
Jede Datei hat Kennungen, die meisten Kennungen kommen in jeder Datei vor, vereinzelt kommen aber auch Kennungen vor, die in nur einer bestimmten Datei vorhanden sind.
Aus dieser Power Query erstelle ich eine neue Tabelle mit VBA (mit Hilfe von einem Dictionary Objekt). In dieser neuen Tabelle ("Aufstellung") werden alle Kennungen einmal aufgelistet also keine doppelten Werte.
Leider werden o.g. vereinzelte Kennungen ganz unten an die Tabelle gepackt, obwohl sie einen bestimmten Platz haben sollen.
Um die vereinzelten Kennungen wieder an die richtige Stelle zu packen habe ich folgenden Code geschrieben, der die vereinzelten Kennungen in "PQ" sucht, die Kennung darüber anschaut (PQKenn_Ueber) und in "Aufstellung" unter PQKenn_Ueber die vereinzelte einfügt. Das soll solange gemacht werden bis die Kennung erreicht ist, die die letzte sein soll.
Sub Sortieren()
'Worksheets definieren
Dim PQ As Worksheet
Dim Aufst As Worksheet
Set PQ = ThisWorkbook.Sheets("PQ")
Set Aufst = ThisWorkbook.Sheets("Aufstellung")
Dim lastRow_LKPQ As Long
Dim LKPQ As String
lastRow_LKPQ = PQ.Cells(PQ.Rows.Count, "G").End(xlUp).Row
LKPQ = "Beispiel Kennung" 'soll die letzte Kennung sein
Dim lastRow_Aufst As Long
lastRow_Aufst = Aufst.Cells(Aufst.Rows.Count, "A").End(xlUp).Row
Dim Versuche As Integer
Dim Gelungen As Integer
For i = lastRow_Aufst To 1 Step -1
Dim LKAufst As String
LKAufst = Aufst.Range("A" & i).Value
If LKAufst = LKPQ Then Exit For
Else
Versuche = Versuche + 1
Dim LKAufst_in_PQ As Range
Set LKAufst_in_PQ = PQ.Range("G:G").Find(what:=LKAufst, LookIn:=xlValues, LookAt:=xlWhole)
PQKenn_Ueber = LKAufst_in_PQ.Offset(-1, 0)
PQKenn_unter = LKAufst_in_PQ.Offset(1, 0)
Dim ASKenn_Ueber As Range
Set ASKenn_Ueber = Aufst.Range("A:A").Find(PQKenn_Ueber, LookIn:=xlValues, LookAt:=xlWhole)
If ASKenn_Ueber.Offset(1, 0) = PQKenn_unter Then
Gelungen = Gelungen + 1
End If
ASKenn_Ueber.Offset(1, 0).EntireRow.Insert
Aufst.Range("A" & i).EntireRow.Select
Selection.Cut
ASKenn_Ueber.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next i
Dim Erfolg As Single
Erfolg = (Gelungen / Versuche) * 100
MsgBox ("Erfolgsquote: " & Erfolg & "%")
End Sub
Der Code macht aber nicht das was er soll, er fügt viele leere Zeilen zwischen den Kennungen ein und sortiert auch nicht wirklich.
Vielleicht findet ja jemand von euch meinen (wahrscheinlich offensichtlichen) Fehler.
Ich danke bereits vielmals im Voraus!
VG
velo
P.S.: Ich weiß das der Code nicht wirklich effizient gestaltet ist, ist aber bei meiner Anwendung jetzt nicht so mega wichtig.