Daten Vergleichen und neue Daten unten anfügen

[David Lange]

Guten Tag,

Zum Sachverhalt ich bekomme Quartalsweise eine gesamt Personalliste diese muss ich in einer anderen Tabelle einlesen, da diese Übersicht mittlerweile
über 500 Datensätze enthält ist das Vergleichen per Hand sehr aufwendig.

Ich würde gern diese beiden Tabellen per VBA mit einander Vergleichen, hierbei sollen neue Daten am ende der Tabelle eingefügt werden und abweichende Daten z.B. gelöscht oder geändert
sollen farblich markiert werden.

Ich hoffe Ihr könnt mir weiterhelfen.

Gruß

David

[Wastl]

Bitte Beispieldatei - kein Bild - anhängen
Danke

[David Lange]

Oh da muss ich eine Beispieltabelle bauen da die Original Tabelle dem Datenschutz unterliegt.

[David Lange]

Angehangen die Beispiel Tabelle ich hoffe die reicht so aus ich musste allerdings alle Namen raus nehmen.

Also in der Tabelle wird in dem Reiter Alpha-Liste die gesamt Personalliste eingelesen und dient als Bezug für die Gesamte Tabelle.
Das wichtigste ist der Reiter EVA hier müssen alle Daten der Alpha liste auftauchen, diese wird Quartalsweise aktualisiert. Dementsprechend
muss die EVA liste auch angepasst werden, wichtig hierbei das nicht einfach Daten gelöscht werden da die eingetragenen Daten in der EVA Liste
3 Jahre bestand haben. Sprich tauchen in der Alpha liste gewisse PersNr´n nicht mehr auf so sollen diese in der EVA liste Rot markiert werden.
Tauchen in de Alphaliste neue PersNr´n auf so sollen diese einfach ans ende der EVA liste gestellt werde.

Bitte nicht wundern in den Reitern sind zum teil noch Schaltflächen und Makros von der eigentlichen Tabelle bitte einfach ignorieren.

Gruß

David

[Wastl]

Hi,

so?

Code:

Option Explicit

Sub vergleic()
Dim ListEva
Dim Listalfa
Dim intI As Integer
Dim intJ As Integer
Dim SuchNr
Dim stimmt As Boolean
Dim Plus As Integer
Dim Ende As Integer

' suchen nach gefülltem Ende in Eva
Ende = ThisWorkbook.Sheets("EVA").Cells(Rows.Count, 1).End(xlUp).Row

'Aufgabenstellung fehlende in Alfa rot zu markieren
Plus = 1
ListEva = ThisWorkbook.Sheets("EVA").Cells(4, 1).CurrentRegion
Listalfa = ThisWorkbook.Sheets("Alpha-Liste").Cells(4, 1).CurrentRegion
For intI = 4 To Ende
   SuchNr = ListEva(intI, 1)
   stimmt = 0
       For intJ = 3 To UBound(Listalfa)
           If SuchNr = Listalfa(intJ, 2) Then
               stimmt = 1
               Exit For
           Else
           End If
       Next intJ
       If intJ = UBound(Listalfa) + 1 And stimmt = 0 Then
           ThisWorkbook.Sheets("EVA").Cells(intI, 1).Font.Color = -16776961
       End If
Next intI

'Aufgabenstellung fehlende in Eva unten zu ergänzen
For intJ = 3 To UBound(Listalfa)
   SuchNr = Listalfa(intJ, 2)
   stimmt = 0
       For intI = 4 To Ende
           If SuchNr = ListEva(intI, 1) Then
               stimmt = 1
               Exit For
           Else
           End If
       Next intI
       If intI = Ende + 1 And stimmt = 0 Then
           ThisWorkbook.Sheets("EVA").Cells(Ende + Plus, 1) = SuchNr
           Plus = Plus + 1
       End If
Next intJ

End Sub

[David Lange]

Super vielen dank macht genau das was es soll.

[David Lange]

Ich habe doch noch ein kleines Problem festgestellt wenn ich das Tabellenblatt Schütze kann ich das Makro nicht mehr verwenden.

[RPP63]

Na, dann hebe den Schutz programmatisch temporär auf und setze ihn zum Schluss wieder.
Alternative:
Setze den Schutz im Workbook_Open mit dem Parameter UserInterfaceOnly:=True

Gruß Ralf