dr.cornwallis
Goto Top

Excel Tabellen Vergleich

Liebe Gemeinde,

ich habe einen VBA Code, dieser vergleicht eine Spalte mit anderen Spalten aus anderen Blättern.
Verglichen wird die Personalnummer.
Jetzt lasse ich den Code für jeden Sheet 1x ausführen(Sheet 2 und Sheet 5).
Der Code soll die Tabellen bzw. Spalten vergleichen und doppelte Einträge löschen.

Sheet 1= ausgeschiedene Mitarbeiter, Sheet 2= alle Mitarbeiter, Sheet 5=alle Mitarbeiter(mit Extras, eine Absolute Auswertung).
Personalnummer in Sheet1: Spalte B
Personalnummer in Sheet2: Spalte E
Personalnummer in Sheet5: Spalte D
Führe ich den Code aus, wird bei Sheet 5 alles sauber gelöscht, bei Sheet 2 hingegen nicht, dort löscht er einfach nicht alle ausgeschiedenen Mitarbeiter, auch wenn ich die pers.Nr in Sheet5 in Reihe D verschiebe...nichts
Ich verstehe das ganze nicht, ich habe im Code nur die Spalte angepasst und schon funktioniert es nicht mehr.

Code:
Public Sub DeleteDuplicates()
    Dim dic As Object, rngDelete As Range, cell As Range
    Set dic = CreateObject("Scripting.Dictionary")  
    'Referenztabelle mit Daten Spalte B in Dictionary laden  
    With Sheets(1)
        For Each cell In .Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)  
            strVal = cell.Value & "|" & cell.Offset(0, 2).Value  
            If Not dic.Exists(strVal) Then
                dic.Add strVal, ""  
            End If
        Next
    End With
    With Sheets(2)
        'Für jede belegte Zelle in Tabelle2  
        For Each cell In .Range("E2:E" & Cells(Rows.Count, "E").End(xlUp).Row)  
            strVal = cell.Value & "|" & cell.Offset(0, 2).Value  
            'prüfe ob Kombination im Dictionary existiert  
            If dic.Exists(strVal) Then
                'Füge Zeile zu einem kombinierten Range zusammen  
                If Not rngDelete Is Nothing Then
                    Set rngDelete = Union(rngDelete, cell.EntireRow)
                Else
                    Set rngDelete = cell.EntireRow
                End If
            End If
        Next
    End With
    'Lösche die gespeicherten Zeilen auf einen Rutsch  
    If Not rngDelete Is Nothing Then
        rngDelete.Delete
    End If
End Sub

Public Sub Wiederholen()
Dim dic As Object, rngDelete As Range, cell As Range
    Set dic = CreateObject("Scripting.Dictionary")  
    'Referenztabelle mit Daten Spalte B in Dictionary laden  
    With Sheets(1)
        For Each cell In .Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)  
            strVal = cell.Value & "|" & cell.Offset(0, 2).Value  
            If Not dic.Exists(strVal) Then
                dic.Add strVal, ""  
            End If
        Next
    End With
    With Sheets(5)
        'Für jede belegte Zelle in Tabelle5  
        For Each cell In .Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)  
            strVal = cell.Value & "|" & cell.Offset(0, 2).Value  
            'prüfe ob Kombination im Dictionary existiert  
            If dic.Exists(strVal) Then
                'Füge Zeile zu einem kombinierten Range zusammen  
                If Not rngDelete Is Nothing Then
                    Set rngDelete = Union(rngDelete, cell.EntireRow)
                Else
                    Set rngDelete = cell.EntireRow
                End If
            End If
        Next
    End With
    'Lösche die gespeicherten Zeilen auf einen Rutsch  
    If Not rngDelete Is Nothing Then
        rngDelete.Delete
    End If
End Sub

Bitte um Hilfe!


Danke euch!

PS: meine VBA Skills sind mehr als bescheiden face-smile

INFO UPDATE: führe ich den Code in Einzelschritten aus, funktioniert es...

Content-Key: 302558

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

Ausgedruckt am: 28.03.2024 um 12:03 Uhr

Mitglied: Dr.Cornwallis
Dr.Cornwallis 22.04.2016 um 08:43:28 Uhr
Goto Top
Hat sich gerade erledigt, ich musste den Code trennen, dann hat es geklappt.


Grüße