Gruppen

Top Gruppen: Windows 7; Windows Vista; Windows XP; Textverarbeitung; Excel; DSL; Internet Browser; E-Mail/Outlook
Betriebsysteme: Windows classik; Linux; BS-Sonstige
Software: Datenbanken; Bildbearbeitung; Audio/mp3/Video; Security/Viren; SW-Sonstige
Hardware: Mainboard/CPU; Grafikkarten; Peripherie; Laptop/Notebook; HW-Sonstiges
Netzwerk: Telefon,ISDN,Modem; W-Lan; NW-Sonstiges
Programmierung: PHP,ASP,Perl...; Java,C++...; Webseiten/HTML
Sonstiges: PC-Sonstiges; Plauderecke; SN Intern; Test

/ Forum / Tabellenkalkulation

Tabellenkalkulation

Fragevon johannes120889 vom 01.04.2022, 15:53 Options

Daten sortieren mit Bedingung in VBA

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

Antwort schreiben

Antwort 1 von nighty vom 01.04.2022, 21:57 Options

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

Antwort 2 von nighty vom 01.04.2022, 22:02 Options

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

Antwort 3 von johannes120889 vom 07.04.2022, 07:54 Options

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

Hinweis

Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..

Neue Einträge

Tipp einschicken

News einschicken