Excel VBA Vergleich von Tabellenbereichen

Hallo in die Runde!

Ich bin noch nicht so sehr fit mit VBA und stehe gerade etwas auf dem Schlauch.
Ich habe eine Tabelle mit 4 Spalten (erzeugt aus zweimal der gleichen Tabelle zu verschiedenen Zeitpunkten) und möchte die ersten beiden Spalten mit den Spalten 3 und 4 vergleichen. Hier mal ein Bild zur Besseren Veranschaulichung:

Ist im rechten Bereich ein Datensatz weggefallen, ist der Rest nach oben gerückt. Es können auch neue Datensätze hinzugekommen sein, diese stehen dann in den beiden rechten Spalten.
Ich möchte die beiden Teiltabellen nun soweit auswerten, dass neben weggefallene Datensätze leere Zellen eingefügt werden. So etwa:

Soviel zur Pflicht. Die Kür wäre, wenn ich diese Daten sortiert nach Identisch, Weggefallen und Neu untereinander darstellen könnte:

Leider finde ich gerade nichtmal den Anfang meines roten Fadens und brauche einen Tritt in die richtige Richtung. Auch im Internet oder hier im Forum habe ich nichts gefunden, was mich jetzt gerade weiterbringt.

Danke schonmal!

B.

Please also mark the comments that contributed to the solution of the article

Content-Key: 428517

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

Printed on: April 16, 2024 at 16:04 o'clock

3 Comments

Latest comment

Ne einfache Pivot-Tabelle nach Nummer gruppiert, feedich

So, ich hab mich mal ganz oldschool mit Zettel und Stift hingesetzt und überlegt, wie ich Schritt für Schritt zu meinem Ergebnis kommen könnte. Lustigerweise hat's dann ga rnicht lange gedauert und ist auch nicht übermäßig kompliziert. Vermutlich nicht der eleganteste Code, den man schreiben kann aber es funktioniert.
Es wird Zeile für Zeile geprüft, ob die Nummern von Spalte A und C gleich oder unterschiedlich sind, sind sie ungleich wird nochmnal differenziert, welche Nummer höher ist und die Daten dieser Nummer mit allem darunter eine Zeile nach unten verschoben.

Der Umweg über Pivot wäre für mich persönlich schwieriger, zumal das Problem nur ein Teil eines größeren VBA-Projektes ist.

Falls es jemandem weiterhelfen könnte, hier mal mein Code:

Sub Zellbereicheverschieben1()

'Deklaration
Dim varlngZeile As Long
Dim varlngZeileEndeA As Long
Dim varlngZeileEndeC As Long
Dim varlngZeileEnde As Long

'Maximale Zeilenzahl ermitteln
varlngZeileEndeA = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
varlngZeileEndeC = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
If varlngZeileEndeA > varlngZeileEndeC Then
varlngZeileEnde = varlngZeileEndeA
Else
varlngZeileEnde = varlngZeileEndeC
End If
MsgBox varlngZeileEnde

'Suchen
For varlngZeile = 1 To varlngZeileEnde
If Cells(varlngZeile, 1) <> Cells(varlngZeile, 3) Then
If Cells(varlngZeile, 1) < Cells(varlngZeile, 3) Then
Range("C" & varlngZeile & ":D" & varlngZeileEnde).Select
Selection.Cut
Cells(varlngZeile + 1, 3).Select
ActiveSheet.Paste

Else
Range("A" & varlngZeile & ":B" & varlngZeileEnde).Select
Selection.Cut
Cells(varlngZeile + 1, 1).Select
ActiveSheet.Paste
End If
Else
End If
Next

End Sub

Joa, umständlich wenns auch einfach geht

.
Hier deine "Kür"

Sub JaLeckMichAmArschThorstenDörnbachImmerNochDerAlteFicker()
    Dim wsSource As Worksheet, wsTarget As Worksheet, rngSearch As Range, f As Range, cell As Range
    Set wsSource = Sheets(1)
    Set wsTarget = Sheets(2)
    With wsSource
        Set rngNum1 = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
        Set rngNum2 = .Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row)  
        
        wsTarget.Range("A1").Value = "Identisch"  
        wsTarget.Range("C1").Value = "Weggefallen"  
        wsTarget.Range("E1").Value = "Neu"  
        wsTarget.Range("1:1").Font.Bold = True  
        For Each cell In rngNum2
            Set f = rngNum1.Find(cell.Value, LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                cell.Resize(1, 2).Copy wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
            Else
                cell.Resize(1, 2).Copy wsTarget.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)  
            End If
        Next
        For Each cell In rngNum1
            Set f = rngNum2.Find(cell.Value, LookIn:=xlValues, Lookat:=xlWhole)
            If f Is Nothing Then
                cell.Resize(1, 2).Copy wsTarget.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)  
            End If
        Next
    End With
End Sub

German solved Question Microsoft Office Microsoft

Hotly discussed

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani