AW: Hilfeeeeee :(
16.06.2006 12:44:03
fcs
Hallo artur,
nicht so ungeduldig, so ein Makro schüttelt man nicht einfach aus dem Ärmel. Außerdem hatte meine 1. Idee aus unbekanntem Grund Probleme mit den Datumsspalten.
Folgendes Makro sollte es tun:
Sub Tabellenvergleich()
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Dim Zeile1 As Long, Zeile2 As Long, Zeile3 As Long
Dim Zellen1 As Range, Zellen2 As Range, Zeile1loeschen As Boolean
Set wks1 = ActiveWorkbook.Sheets("Tabelle1") 'Tabelle mit Quelldaten
Set wks2 = ActiveWorkbook.Sheets("Tabelle2") 'Tabelle mit Vergleichsdaten
Set wks3 = ActiveWorkbook.Sheets("Tabelle3") 'Tabelle für Duplikate
Zeile3 = 1
For Zeile1 = wks1.Cells(65536, "A").End(xlUp).Row To 1 Step -1
Zeile1loeschen = False
Set Zellen1 = wks1.Range(wks1.Cells(Zeile1, "A"), wks1.Cells(Zeile1, "I"))
For Zeile2 = wks2.Cells(65536, "A").End(xlUp).Row To 1 Step -1
Set Zellen2 = wks2.Range(wks2.Cells(Zeile2, "A"), wks2.Cells(Zeile2, "I"))
If Zellen1(1, "C") = Zellen2(1, "C") And Zellen1(1, "D") = Zellen2(1, "D") And _
Zellen1(1, "E") = Zellen2(1, "E") And Zellen1(1, "F") = Zellen2(1, "F") Then
Zellen1.Copy
wks3.Cells(Zeile3, "A").PasteSpecial Paste:=xlPasteValues
Zellen2.Copy
wks3.Cells(Zeile3, "J").PasteSpecial Paste:=xlPasteValues
Zellen2.Delete Shift:=xlUp
Zeile3 = Zeile3 + 1
Zeile1loeschen = True
End If
Next Zeile2
If Zeile1loeschen = True Then
Zellen1.Delete Shift:=xlUp
End If
Next Zeile1
Application.CutCopyMode = False
MsgBox "Tabellenvergleich ist abgeschlossen"
End Sub
mfg
Franz