Daten sortieren mit Bedingung in VBA

Question

Hallo,

ich habe ein Problem mit einer großen Datenmenge in Excel, aber leider noch nie VBA gemacht.
Das Problem ist eigentlich recht simpel: Ich habe eine Auflistung und die Spalten B, F und G belegt. Derzeit ist es so, dass die Liste nach den Werten in Spalte B sortiert ist. Für die gleichen Werte in Spalte B gibt es verschiedene Werte in den Spalten F und G. Also gibt es mehrere Zeilen mit dem gleichen Wert in Spalte B.
Was ich aber am Ende haben will, ist, dass es für jeden Wert aus Spalte B nur noch eine Zeile i gibt und alle zugehörigen Einträge aus den Spalten F und G dann in den Zelle (F, i) bzw. (G, i) stehen.
Im Folgenden ein Beispiel zur Verdeutlichung:

Gegenwärtige Situation:

B F G
1 a g
2 b g
2 c g
2 c f
3 a g
3 a f

Was ich eigentlich haben will:

B F G
1 a g
2 b,c g,f
3 a g,f

Was ich mir überlegt habe ist dieser Pseudocode:

For i=1..sehrgroßeZahl
if ( Cell(B,i)=Cell(B,i-1) )
do
if ( Cell (F,i)0Cell(F,i-1) )
add Cell(G,i),Cell (G,i-1)
else add Cell(F, i),Cell(F,i-1)
delete Zeile(i)
else i=i+1

Die Einträge in allen Spalten sind übrigens Buchstaben und Zahlen gemischt. Man müsste sie irgendwie als String vergleichen und hintereinanderschreiben.
Meint ihr, das geht so irgendwie?

Viele Grüße

Johannes

Answer 1

hi johannes ^^

wie gewuenscht :-)

gruss nighty

Sub NeuSortierung()
Dim ZeilenAnz As Long, ArrayAnz As Long
Dim IndexA As Long, IndexB As Long, IndexC As Long
Dim Lzeile As Long
Lzeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ReDim WksArrayBalt(Lzeile, 1) As Variant
ReDim WksArrayFGalt(Lzeile, 2) As Variant
ReDim WksArrayBneu(1 To Lzeile, 1 To 1) As Variant
ReDim WksArrayFGneu(1 To Lzeile, 1 To 2) As Variant
WksArrayBalt() = Range(Cells(1, 2), Cells(Lzeile, 2))
WksArrayFGalt() = Range(Cells(1, 6), Cells(Lzeile, 7))
For ZeilenAnz = 1 To Lzeile
For ArrayAnz = 1 To Lzeile
If WksArrayBalt(ZeilenAnz, 1) <> WksArrayBneu(ArrayAnz, 1) Then
IndexB = IndexB + 1
IndexC = ArrayAnz
Else
IndexC = ArrayAnz
Exit For
End If
Next ArrayAnz
If IndexB = 6 Then
IndexA = IndexA + 1
WksArrayBneu(IndexA, 1) = WksArrayBalt(ZeilenAnz, 1)
WksArrayFGneu(IndexA, 1) = WksArrayFGalt(ZeilenAnz, 1)
WksArrayFGneu(IndexA, 2) = WksArrayFGalt(ZeilenAnz, 2)
Else
WksArrayFGneu(IndexC, 1) = WksArrayFGneu(IndexC, 1) & "," & WksArrayFGalt(ZeilenAnz, 1)
WksArrayFGneu(IndexC, 2) = WksArrayFGneu(IndexC, 2) & "," & WksArrayFGalt(ZeilenAnz, 2)
End If
IndexB = 0
Next ZeilenAnz
Range(Cells(1, 2), Cells(Lzeile, 2)).Resize(UBound(WksArrayBneu())) = WksArrayBneu()
Range(Cells(1, 6), Cells(Lzeile, 7)).Resize(UBound(WksArrayFGneu())) = WksArrayFGneu()
End Sub

Answer 2

hi johannes ^^

ops korrigiert

gruss nighty

Sub NeuSortierung()
Dim ZeilenAnz As Long, ArrayAnz As Long
Dim IndexA As Long, IndexB As Long, IndexC As Long
Dim Lzeile As Long
Lzeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ReDim WksArrayBalt(Lzeile, 1) As Variant
ReDim WksArrayFGalt(Lzeile, 2) As Variant
ReDim WksArrayBneu(1 To Lzeile, 1 To 1) As Variant
ReDim WksArrayFGneu(1 To Lzeile, 1 To 2) As Variant
WksArrayBalt() = Range(Cells(1, 2), Cells(Lzeile, 2))
WksArrayFGalt() = Range(Cells(1, 6), Cells(Lzeile, 7))
For ZeilenAnz = 1 To Lzeile
For ArrayAnz = 1 To Lzeile
If WksArrayBalt(ZeilenAnz, 1) <> WksArrayBneu(ArrayAnz, 1) Then
IndexB = IndexB + 1
IndexC = ArrayAnz
Else
IndexC = ArrayAnz
Exit For
End If
Next ArrayAnz
If IndexB = Lzeile Then
IndexA = IndexA + 1
WksArrayBneu(IndexA, 1) = WksArrayBalt(ZeilenAnz, 1)
WksArrayFGneu(IndexA, 1) = WksArrayFGalt(ZeilenAnz, 1)
WksArrayFGneu(IndexA, 2) = WksArrayFGalt(ZeilenAnz, 2)
Else
WksArrayFGneu(IndexC, 1) = WksArrayFGneu(IndexC, 1) & "," & WksArrayFGalt(ZeilenAnz, 1)
WksArrayFGneu(IndexC, 2) = WksArrayFGneu(IndexC, 2) & "," & WksArrayFGalt(ZeilenAnz, 2)
End If
IndexB = 0
Next ZeilenAnz
Range(Cells(1, 2), Cells(Lzeile, 2)).Resize(UBound(WksArrayBneu())) = WksArrayBneu()
Range(Cells(1, 6), Cells(Lzeile, 7)).Resize(UBound(WksArrayFGneu())) = WksArrayFGneu()
End Sub

Answer 3

hi nighty,

leider war ich über die Ostertage nicht da und habe deswege nicht hier reingeschaut. Vielen vielen Dank für Deine Antwort, werd ich heute gleich ausprobieren und versuchen, den Code zu verstehen und zu lernen, damit ich in Zukunft keine blöden Fragen stellen muss ;-).

Viele Grüße

Johannes