Option
Explicit
Sub
vergleichen()
Dim
ende
As
Long
Dim
ende2
As
Long
Dim
i
As
Long
Dim
j
As
Long
Dim
k
As
Long
Dim
anzahl1
As
Long
Dim
anzahl2
As
Long
Dim
zeile2
As
Long
Dim
zeile22
As
Long
Dim
eins
As
Object
Dim
zwei
As
Object
Dim
inhalt11
Dim
inhalt12
Dim
inhalt21
Dim
inhalt22
Dim
ident1
As
Long
Dim
ident2
As
Long
Application.ScreenUpdating =
False
Set
eins = Worksheets(1)
Set
zwei = Worksheets(2)
zwei.UsedRange.Interior.ColorIndex = xlNone
ende = eins.Cells(Rows.Count, 1).
End
(xlUp).Row
ende2 = zwei.Cells(Rows.Count, 1).
End
(xlUp).Row
For
i = 1
To
ende
anzahl1 = Application.WorksheetFunction.CountIf(eins.Columns(1), eins.Cells(i, 1))
anzahl2 = Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(i, 1))
Select
Case
anzahl1 & anzahl2
Case
22, 11
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
For
j = 1
To
anzahl1
If
j = 2
Then
zeile2 = zeile2 + Application.WorksheetFunction.Match(eins.Cells(i + 1, 1), zwei.Range(zwei.Cells(zeile2 + 1, 1), zwei.Cells(ende2, 1)), 0)
For
k = 1
To
26
If
zwei.Cells(zeile2, k) <> eins.Cells(i + j - 1, k)
Then
zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next
k
zwei.Cells(zeile2, 27) =
"x"
Next
j
Case
21
inhalt11 = eins.Range(eins.Cells(i, 1), eins.Cells(i, 26))
inhalt12 = eins.Range(eins.Cells(i + 1, 1), eins.Cells(i + 1, 26))
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
inhalt21 = zwei.Range(zwei.Cells(zeile2, 1), zwei.Cells(zeile2, 26))
ident1 = 0
ident2 = 0
For
k = 1
To
26
If
inhalt11(1, k) = inhalt21(1, k)
Then
ident1 = ident1 + 1
If
inhalt12(1, k) = inhalt21(1, k)
Then
ident2 = ident2 + 1
Next
k
j = 2
If
ident1 > ident2
Then
j = 1
For
k = 1
To
26
If
zwei.Cells(zeile2, k) <> eins.Cells(i + j - 1, k)
Then
zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next
k
zwei.Cells(zeile2, 27) =
"x"
Case
20, 10
Case
12
inhalt11 = eins.Range(eins.Cells(i, 1), eins.Cells(i, 26))
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
inhalt21 = zwei.Range(zwei.Cells(zeile2, 1), zwei.Cells(zeile2, 26))
zeile22 = zeile2 + Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Range(zwei.Cells(zeile2 + 1, 1), zwei.Cells(ende2, 1)), 0)
inhalt22 = zwei.Range(zwei.Cells(zeile22, 1), zwei.Cells(zeile22, 26))
ident1 = 0
ident2 = 0
For
k = 1
To
26
If
inhalt11(1, k) = inhalt21(1, k)
Then
ident1 = ident1 + 1
If
inhalt11(1, k) = inhalt22(1, k)
Then
ident2 = ident2 + 1
Next
k
If
ident1 < ident2
Then
zeile2 = zeile22
For
k = 1
To
26
If
zwei.Cells(zeile2, k) <> eins.Cells(i, k)
Then
zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next
k
zwei.Cells(zeile2, 27) =
"x"
Case
Else
End
Select
i = i + anzahl1 - 1
Next
i
For
i = 1
To
ende2
If
zwei.Cells(i, 27) <>
"x"
Then
zwei.Range(zwei.Cells(i, 1), zwei.Cells(i, 26)).Interior.ColorIndex = 6
Next
i
zwei.Columns(
"AA"
).ClearContents
Set
eins =
Nothing
Set
zwei =
Nothing
Application.ScreenUpdating =
True
End
Sub