Sub
AbgleichListe()
Dim
Wks
As
Worksheet
Dim
x
As
Long
Dim
Finden
As
Range
Dim
EndLine
As
Long
Sheets(
"Abgleich"
).Activate
Set
Wks = Sheets(
"Liste"
)
EndLine = Sheets(
"Abgleich"
).Cells(Rows.Count,
"B"
).
End
(xlUp).Row
For
x = EndLine
To
2
Step
-1
Set
Finden = Wks.Columns(
"a"
).Find(Sheets(
"Abgleich"
).Cells(x,
"b"
), LookIn:=xlValues, LookAt:=xlWhole)
If
Not
Finden
Is
Nothing
Then
Sheets(
"Abgleich"
).Rows(x + 1).Insert Shift:=xlDown
Range(Wks.Cells(Finden.Row,
"A"
), Wks.Cells(Finden.Row,
"G"
)).Copy Destination:=Sheets(
"Abgleich"
).Cells(x + 1,
"b"
)
End
If
Next
End
Sub