Vergleichen und hintereinander schreiben

Guten morgen, vielen Dank an alle die mir eben bei der Uhrzeit geholfen haben.
Jetzt ergibt sich ein weiter Problem:
Ich habe eine Datei mit 2 Arbeitsblätter. In diesen Arbeitsblättern sind jeweils die Splaten C;D;E,;F Zeilenweise miteinander zu vergleichen. Bei Übereinstimmung z.b. der Zeile C1;D1;E1;F1 mit irgendeiner Zeile in dem anderen Arbeitsblatt, soll von dem Arbeitsblatt 1 die komplette Zeile und die dazugehörige Zeile aus dem Arbeitsblatt 2 in ein neue Arbeitsblatt hintereinander kopiert werden. Die geprüften Zeile sollen danach gelöscht werden.
Ich weiß kling etwa komplziert, deswegen hier eine Beispiel datei.
https://www.herber.de/bbs/user/34404.xls
Ich hoffe das geht irgendwie mit einem Makro.
Vielen Dank im voraus
mfg
artur

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hilfeeeeee :(

16.06.2006 11:36:59

arturhirsch

AW: Hilfeeeeee :(

16.06.2006 12:44:03

fcs

AW: Hilfeeeeee :(

16.06.2006 13:31:57

arturhirsch

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

Beliebteste Forumthreads (12 Monate)

Vergleichen und hintereinander schreiben

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread