lebmug
Goto Top

Excel: Tabelle nach Pärchen durchsuchen und gruppieren

Hallo zusammen,

ich habe eine Excel-Sheet mit 6 Spalten, davon jeweils 3 aus einer Perspektive:

ID1, Volumen1, Anzahl1, ID2, Volumen2, Anzahl2

Darin sind in gerne mal mehr als 50.000 Zeilen eintragungen, die ich vergleiche muss.

In einer idealen Welt würden hierbei alle bei ID1 vorkommenden IDs ebenfalls in ID2 zu finden sind und umgedreht, was selten der Fall ist.

Bisher geh ich immer manuell los und verschieb mir alle Einträge so dass zum Schluss jede Zeile eine ID behandelt (wenn eine ID nur in einer der beiden Spalten vorkommt bleiben die drei dazugehörigen Felder des Schwesterbereichs leer).

Gibt es ein Script oder eine andere Möglichkeit das zu automatisieren?


Ein vereinfachtes Beispiel:

Aus

Apfel,2,1,Apfel,2,1
Birne,3,1,Birne,3,1
Banane,1,1,Plfaume,5,2

soll werden

Apfel,2,1,Apfel,2,1
Birne,3,1,Birne,3,1
Banane,1,1,(Leer),(Leer),(Leer)
(Leer),(Leer),(Leer),Plfaume,5,2

Kann mir da jemand weiterhelfen?

Vielen Dank!

MFG
lebmug

Content-Key: 258305

Url: https://administrator.de/contentid/258305

Ausgedruckt am: 28.03.2024 um 23:03 Uhr

Mitglied: colinardo
colinardo 22.12.2014 aktualisiert um 17:39:57 Uhr
Goto Top
Hallo lebmug, Willkommen auf Administrator.de!
Guckst du in dieses Demo-Sheet: match_pairs_258305.xlsm face-wink
Sub MatchPairs()
    Dim ws As Worksheet, rngA As Range, rngB As Range, f As Range, cell As Range
    'Arbeitsblatt wählen  
    Set ws = Sheets(1)
    Application.ScreenUpdating = False
    With ws
        'Bereich A  
        Set rngA = .Range("A2:A" & ws.UsedRange.Rows.Count)  
        'Bereich B  
        Set rngB = .Range("D2:D" & ws.UsedRange.Rows.Count)  
        ' Bei Bedarf vorher beide Bereiche sortieren  
        'rngA.Sort rngA.Columns(1), xlAscending  
        'rngB.Sort rngB.Columns(1), xlAscending  
        
        'Für alle IDs in Bereich A  
        For Each cell In rngA
            'Wenn ID nicht leer  
            If cell.Value <> "" Then  
                'Suche aktuelle ID in Bereich B  
                Set f = rngB.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                'Wenn passende ID gefunden wurde  
                If Not f Is Nothing Then
                    'wenn aktuelle Zeile nicht gleich der gefundenenen (andernfalls is ja kein Umsetzen nötig)  
                    If f.Row <> cell.Row Then
                        'Verschiebe die 3 Zellen der gefundenen ID in die aktuelle Zeile  
                        f.Resize(1, 3).Cut
                        cell.Offset(0, 3).Resize(1, 3).Insert xlDown
                    End If
                Else
                    'es wurde keine passende ID gefunden füge leere Zellen ein  
                    cell.Offset(0, 3).Resize(1, 3).Insert xlDown, xlFormatFromLeftOrAbove
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Grüße Uwe