Excel Tabellenabgleich
Manuel
ich habe in VBA ein Script, welches zwei Tabellen anhand einer ID gegenprüft und die Daten überschreibt, bzw. neue Datensätze anfügt.
Nun ist es aber so, das in der Originaldatei, die aktualisiert werden soll weitere Spalten mit zusätzlichen Infos enthalten sind.
Das Problem ist nun allerdings, das die zusätzlichen Spalten zwar stehen bleiben, wenn jedoch eine ID in der neueren Datei (Tabelle2) nicht mehr auftaucht, wird diese bisher nach unten mit der Überschrift "folgende Datensätze sind nicht in Tabelle2 enthalten" gesetzt. Neue ID's werden an die bestehenden Daten rangehängt. Die Spalten rechts von der ID bleiben aber auf ihrem Ort, d.h. ID 4 wird nach unten gesetzt, das sie in der neuen Tabelle nicht mehr vorhanden ist, die zus. Spalten bleiben aber in der Zeile stehen. Wird nun eine ID aus der neuen Tabelle in diese Tabelle kopiert, hat diese ID nun die zus. Spalten mit aufgeführt.
Kann mir jemand sagen, wie ich das Script anpasse, damit diese Spalten bestehen bleiben?
Vielen Dank im Voraus.
Manuel
[code]
Sub DatenAbgleich()
Dim arrT2 As Variant, arrT1 As Variant, arrRest As Variant
Dim i As Long, j As Long, k As Long
With Sheets("Tabelle1")
arrT1 = .Range("A1", .Range("H" & Rows.Count).End(xlUp))
End With
With Sheets("Tabelle2")
arrT2 = .Range("A1", .Range("H" & Rows.Count).End(xlUp))
End With
For i = 1 To UBound(arrT2)
For j = 1 To UBound(arrT1)
If arrT1(j, 1) = arrT2(i, 1) Then
arrT1(j, 1) = ""
Exit For
End If
Next
Next
k = 1
ReDim arrRest(1 To 8, 1 To k)
arrRest(1, 1) = "folgende Datensätze sind nicht in Tabelle2 enthalten"
For j = 1 To UBound(arrT1)
If arrT1(j, 1) "" Then
k = k + 1
ReDim Preserve arrRest(1 To 8, 1 To k)
For i = 1 To 8
arrRest(i, k) = arrT1(j, i)
Next
End If
Next
With Sheets("Tabelle1")
UsedRange.Columns("A:H").ClearContents
.Cells(1, 1).Resize(UBound(arrT2), 8) = arrT2
.Cells(UBound(arrT2) + 1, 1).Resize(UBound(arrRest, 2), 8) = WorksheetFunction. _
Transpose(arrRest)
.Cells(UBound(arrT2) + 1 + UBound(arrRest, 2) + 1, "A") = "Ausgeführt am " & Format( _
Date, "DD.MM.YYYY") & " um " & Format(Now, "hh:mm") & " Uhr"
End With
End Sub
[/code]