2 Tabellen abgleichen

Forumthread: 2 Tabellen abgleichen

05.01.2015 21:09:55

Peter

Hallo,
ich möchte die Spalte 3 in den Tabellen "D" und "B" vergleichen. Bei Übereinstimmung wird von der entspr. Zeile, der Spaltenbereich " L bis Z" von Tabelle "D" in die Tabelle "B" eingefügt.
Bis hier OK.
Im nächsten Schritt sollen wieder die Spalte 3 in den Tabellen "D" und "B" verglichen werden.
Bei NICHT-Übereinstimmung sollen diese Zeilen in die Tabelle "A" eingefügt werden und zum Schluss alle nichtleeren Zeilen in der Tabelle "D "gelöscht werden.
-siehe auch Anlagedatei-
https://www.herber.de/bbs/user/94769.xls
Vielen Dank im voraus
Peter

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: 2 Tabellen abgleichen

06.01.2015 12:52:32

Klaus
AW: 2 Tabellen abgleichen

08.01.2015 21:27:10

Peter

AW: 2 Tabellen abgleichen

06.01.2015 12:52:32

Klaus

Hallo Peter,
folgener Code funktioniert in deiner Musterdatei:

Option Explicit
Sub TabellenAbgleichen()
'Spalte 3 aus "B" und "D" vergleichen.
'Bei Gleichheit Inhalt aus "D" in "B" einfügen.
'Sonst Inhalt aus "D" in "A" einfügen.
'Inhalt D löschen
Const SpalteAb As Long = 12    'von Spalte L
Const SpalteBis As Long = 26   'bis Spalte Z
Const SpalteVergleich As Long = 3  'in Spalte C vergleichen
Const ZeileAb As Long = 2      'in Zeile 1 stehen überschriften
Dim ShZ As Worksheet, ShQ As Worksheet, ShA As Worksheet
Set ShQ = Worksheets("D")
Set ShZ = Worksheets("B")
Set ShA = Worksheets("A")
Dim ZeileBis As Long
Dim r As Range
Dim ZeileRein As Long
Dim ZeileLetzteA
With ShA 'freie Zeile in A feststellen
ZeileLetzteA = .Cells(.Rows.Count, SpalteVergleich).End(xlUp).Row
End With
With ShQ
'letzte Zeile feststellen
ZeileBis = .Cells(.Rows.Count, SpalteVergleich).End(xlUp).Row
'Alle Zeilen durchgehen
For Each r In .Range(.Cells(ZeileAb, SpalteVergleich), .Cells(ZeileBis, SpalteVergleich))
'Kommt ArtNr in B vor?
If WorksheetFunction.CountIf(Sheets("B").Cells(1, SpalteVergleich).EntireColumn, r. _
Value) = 1 Then
.Range(.Cells(r.Row, SpalteAb), .Cells(r.Row, SpalteBis)).Copy
ShZ.Cells(WorksheetFunction.Match(r.Value, ShZ.Cells(1, SpalteVergleich). _
EntireColumn, False), SpalteAb).PasteSpecial
Application.CutCopyMode = False
Else 'oder nicht?
ZeileLetzteA = ZeileLetzteA + 1
.Cells(r.Row, SpalteAb).EntireRow.Copy
ShA.Cells(ZeileLetzteA, 1).PasteSpecial
End If
'Zeileninhalt löschen
.Cells(r.Row, 1).EntireRow.ClearContents
Next r
End With

Grüße,
Klaus M.vdT.

AW: 2 Tabellen abgleichen

08.01.2015 21:27:10

Peter

Vielen Dank.
Du hast mir sehr weitergeholfen.
Peter

Beliebteste Forumthreads (12 Monate)

Forumthread: 2 Tabellen abgleichen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread