Tabellen vergleichen - Code anwendbar?
29.11.2008 21:43:00
Wolfgang
in einer Excel-Mappe befinden sich zwei Tabellenblätter "Grunddaten" und "Altdaten"; über einen Code werden bis maximal 4 Tabellenblätter -ausgeblendet- hineinkopiert (ggfs. Tabelle1, Tabelle2, Tabelle3 und Tabelle4), deren Format mit den beiden Blättern Grunddaten und Altdaten übereinstimmt. Wie kann ich erreichen, dass die beiden Blätter mit den maximal 4 Blättern verglichen werden und Änderungen in den Spalten I:K (nur hier sind Änderungen möglich) in die beiden Tabellen Grunddaten und Altdaten hineinkopiert werden. Daten, die in den beiden Tabellenblättern und auch in den Tabellen 1-4 unveränderlich sind, sind in den Spalten D und F enthalten und somit evtl. für einen gezielteren Abgleich denkbar (?). Ich habe unter Recherche untenstehenden Code entdeckt, ohne aber zu wissen, ob er für mein Anliegen verwendbar ist und wie ich ihn ggfs. anpassen könnte. Daher wäre ich für Rückmeldungen sehr dankbar.
Herzliche Grüße Wolfgang
Hier der Code von Franz aus Recherche:
Sub Vergleich_Makro()
Application.ScreenUpdating = False
Dim i As Long
Dim strKunde, strAnsprech
Dim wksKunde As Worksheet, wksXX As Worksheet, wksInt As Worksheet
Dim rngSuchen As Range, strAddresse As String
Dim boGefunden As Boolean
Set wksKunde = Worksheets("Kunden")
Set wksXX = Worksheets("XX")
Set wksInt = Worksheets("Interessenten")
For i = 2 To wksXX.Cells(wksXX.Rows.Count, 3).End(xlUp).Row 'Zeilen im Blatt XX
strKunde = wksXX.Cells(i, 3).Value 'Wert Spalte C
strAnsprech = wksXX.Cells(i, 15).Value 'Wert Spalte O
'Prüfen ob Eintrag in XX Spalte C schon im Blatt Kunden vorhanden ist
boGefunden = False
Set rngSuchen = wksKunde.Columns(3).Find(what:=strKunde, LookIn:=xlValues, _
lookat:=xlWhole)
If rngSuchen Is Nothing Then
'Prüfen ob Eintrag in XX Spalte C schon im Blatt Interessenten vorhanden ist
Set rngSuchen = wksInt.Columns(3).Find(what:=strKunde, LookIn:=xlValues, _
lookat:=xlWhole)
If Not rngSuchen Is Nothing Then
strAddresse = rngSuchen.Address
'Prüfen ob für einen Eintrag im Blatt Interessenten die Spalte O übereinstimmt
Do
If strAnsprech = wksInt.Cells(rngSuchen.Row, 15) Then
wksXX.Cells(i, 1) = "L"
boGefunden = True
Exit Do
End If
Set rngSuchen = wksInt.Columns(3).FindNext(After:=rngSuchen)
Loop Until rngSuchen.Address = strAddresse
End If
Else
strAddresse = rngSuchen.Address
'Prüfen ob für einen Eintrag im Blatt Kunden die Spalte O übereinstimmt
Do
If strAnsprech = wksKunde.Cells(rngSuchen.Row, 15) Then
wksXX.Cells(i, 1) = "L"
boGefunden = True
Exit Do
End If
Set rngSuchen = wksKunde.Columns(3).FindNext(After:=rngSuchen)
Loop Until rngSuchen.Address = strAddresse
End If
If boGefunden = False Then wksXX.Cells(i, 1) = "N"
Next i
Application.ScreenUpdating = True
End Sub