Office: 2 Excel Sheets vergleichen und in eine 3te schreiben

Hallo Leute!

Habe da ein kleines Problem ich möchte 2 excel sheets mit 11 tabellen und ca. 500 einträgen vergleichen.

Das Problem ist das Script funktioniert soweit nur er schreib mit in die 3te Tabelle nur die gelöschten rein aber die was unterschiedlich von den inserts sind nicht.

Hoffe ihr könnt mir helfen anbei der Code

Code:

Option Explicit
Sub Master()

Dim i As Integer

' Hier die Anzahl der Spalten eingegben (z.B.: 3):
For i = 1 To 11
Call Vergleich(i)
Next

End Sub

Function Vergleich(akspa As Integer)
Dim verg1(5000) As String
Dim verg2(5000) As String
Dim merk1(5000) As String
Dim merk2(5000) As String
Dim dopp(5000) As Integer
Dim z As Integer
Dim y As Integer
Dim r As Integer
Dim s As Integer
Dim t, tt As Integer
Dim v, vv As Integer
Dim w, ww As Integer

z = 4
Do While Worksheets("Gesamt").Cells(z, akspa) <> ""
verg1(z) = Worksheets("Gesamt").Cells(z, akspa)
z = z + 1
Loop
' Werte aus Tabelle 2 einlesen
y = 4
Do While Worksheets("Gesamt2").Cells(y, akspa) <> ""
verg2(y) = Worksheets("Gesamt2").Cells(y, akspa)
y = y + 1
Loop
' Werte vergleichen
r = 1
s = 1
For r = 1 To z - 1
For s = 1 To y - 1
' Gleiche Werte markieren
If verg1(r) = verg2(s) Then merk1(r) = "ja"
If verg2(s) = verg1(r) Then merk2(s) = "ja"
If verg1(r) = verg2(s) Then
dopp(r) = 1
'Cells(s, akspa) = ""
End If

Next s
Next r
' Ungleiche Werte aus Tabelle 1 ausgeben
t = 1
For t = 1 To r
If merk1(t) <> "ja" Then
tt = tt + 1
Worksheets("Gesamt2").Select
Worksheets("Gesamt2").Rows(t).Copy
Worksheets("Prüfung").Select
'Worksheets("Prüfung").Cells(tt, 1) = verg1(t)
Worksheets("Prüfung").Cells(tt, 1).Select
ActiveSheet.Paste
End If
Next t

' Ungleiche Werte aus Tabelle 2 ausgeben
v = 1
For v = 1 To s
If merk2(v) <> "ja" Then
vv = vv + 1
Worksheets("Gesamt2").Select
Worksheets("Gesamt2").Rows(v).Copy
Worksheets("Prüfung").Select
'Worksheets("Prüfung").Cells(vv, 1) = verg2(v)
Worksheets("Prüfung").Cells(vv, 1).Select
ActiveSheet.Paste
End If
Next v

' Inhalte vergleichen ausgeben
w = 1
For w = 1 To s
If dopp(w) = 0 Then
ww = ww + 1
Worksheets("Gesamt2").Select
Worksheets("Gesamt2").Rows(w).Copy
Worksheets("Prüfung").Select
Worksheets("Prüfung").Cells(ww, 1).Select
ActiveSheet.Paste
End If
Next w
Application.CutCopyMode = False
'Cells.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Function