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
anders
As
Long
Dim
ende
As
Long
Application.ScreenUpdating =
False
Set
eins = Worksheets(1)
Set
zwei = Worksheets(2)
zwei.UsedRange.Interior.ColorIndex = xlNone
If
eins.Cells(2, 1) <>
""
Then
anzahl = Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(2, 1))
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
MsgBox
"Die Daten waren noch nicht vorhanden. Sie wurden am Ende eingefügt!"
Else
anders = 0
zeile = Application.WorksheetFunction.Match(eins.Cells(2, 1), 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
anders = anders + 1
End
If
Next
j
zwei.Cells(zeile, 1).Interior.ColorIndex = 6
If
anders = 0
Then
MsgBox
"Die Daten waren mit den selben Werten vorhanden!"
Else
MsgBox
"Die Daten waren vorhanden! Es gab allerdings "
& anzahl &
" unterschiedliche Werte. Diese wurden farbig markiert aber nicht geändert."
End
If
End
If
End
If
Set
eins =
Nothing
Set
zwei =
Nothing
Application.ScreenUpdating =
True
End
Sub