Option
Explicit
Sub
ListeNeuBereinigen()
Rem in NEU verbleibt was in BESTAND nicht enthalten
Const
fRow = 3
Dim
ShN
As
Worksheet
Dim
ShB
As
Worksheet
Dim
nRng
As
Range, c
As
Range, k
As
Range
Dim
lRow
As
Long
, y
As
Long
Dim
x
As
Integer
Dim
aStr
As
String
, nStr
As
String
, bstr
As
String
Dim
Spalten(1
To
3)
As
Long
Spalten(1) = 1
Spalten(2) = 4
Spalten(3) = 6
Set
ShN = Sheets(
"NEU"
)
Set
ShB = Sheets(
"BESTAND"
)
lRow = ShN.Cells.Find(
"*"
, [a1], , , xlByRows, xlPrevious).Row
Set
nRng = Range(ShN.Cells(fRow, 1), ShN.Cells(lRow, 1))
Application.ScreenUpdating =
False
For
Each
c
In
nRng
nStr = c.Value
For
x = 1
To
3
nStr = nStr & c.Offset(0, Spalten(x)).Value
Next
x
With
ShB.Columns(1)
Set
k = .Find(c.Value)
If
Not
k
Is
Nothing
Then
aStr = k.Address
Do
bstr = k.Value
For
x = 1
To
3
bstr = bstr & k.Offset(0, Spalten(x)).Value
Next
x
If
nStr = bstr
Then
c.Value =
""
Set
k = .FindNext(k)
Loop
While
Not
k
Is
Nothing
And
k.Address <> aStr
End
If
End
With
Next
c
With
ShN
For
y = lRow
To
fRow
Step
-1
If
.Cells(y, 1).Value =
""
Then
Rows(y).Delete
Next
y
End
With
Application.ScreenUpdating =
True
End
Sub