Option
Explicit
Sub
vergleichen()
Dim
j
As
Long
Dim
eins
As
Object
Dim
zwei
As
Object
Dim
anzahl
As
Long
Dim
zeile
As
Long
Dim
ende
As
Long
Dim
ende1
As
Long
Dim
i
As
Long
Dim
suche
As
String
Dim
zeilenneu
As
Long
Application.ScreenUpdating =
False
Set
eins = Worksheets(1)
Set
zwei = Worksheets(2)
eins.UsedRange.Interior.ColorIndex = xlNone
zwei.UsedRange.Interior.ColorIndex = xlNone
ende1 = eins.Cells(Rows.Count, 1).
End
(xlUp).Row
If
ende1 = 1
Then
End
zeilenneu = 0
For
i = 2
To
ende1
suche = eins.Cells(i, 1)
If
suche <>
""
Then
anzahl = Application.WorksheetFunction.CountIf(zwei.Columns(1), suche)
If
anzahl = 0
Then
ende = zwei.Cells(Rows.Count, 1).
End
(xlUp).Row
If
ende = 1
Then
ende = 3
eins.Rows(2).Copy zwei.Rows(ende + 1)
zwei.Cells(ende + 1, 1).Interior.ColorIndex = 6
eins.Cells(i, 1).Interior.ColorIndex = 3
zeilenneu = zeilenneu + 1
Else
zeile = Application.WorksheetFunction.Match(suche, zwei.Columns(1), 0)
For
j = 3
To
9
If
zwei.Cells(zeile, j) <> eins.Cells(2, j)
Then
zwei.Cells(zeile, j).Interior.ColorIndex = 6
eins.Cells(2, j).Interior.ColorIndex = 6
End
If
Next
j
eins.Cells(i, 1).Interior.ColorIndex = 6
zwei.Cells(zeile, 1).Interior.ColorIndex = 6
End
If
End
If
Next
i
MsgBox
"Es wurden "
& ende1 &
" Zeilen überprüft."
& Chr(10) &
" Dabei wurden "
& zeilenneu &
" Zeilen neu eingefügt. Diese sind rot markiert."
& Chr(10) &
"Bei den anderen wurden die Änderungen gelb hervorgehoben."
Set
eins =
Nothing
Set
zwei =
Nothing
Application.ScreenUpdating =
True
End
Sub