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.