Vielen Dank für den Hinweis Magnus! Mit chrome ist es gelaufen 


Private Sub Cancel_Click()
    Unload Win
End Sub
Private Sub Start_Click()
    Dim reportneu, reportalt, dokneu As Worksheet, dokalt As Worksheet, repneu As Worksheet, repalt As Worksheet, wbk As Workbook, pfad As String
    reportneu = Application.GetOpenFilename
    If reportneu = False Then
        Exit Sub
    Else
        Set dokneu = Workbooks.Open(reportneu).Worksheets("DOK")
        Set repneu = ActiveWorkbook.Worksheets("REP")
    End If
    pfad = dokneu.Parent.Path
    reportalt = Application.GetOpenFilename
    If reportalt = False Then
        Exit Sub
    Else
        Set dokalt = Workbooks.Open(reportalt).Worksheets("DOK")
        Set repalt = ActiveWorkbook.Worksheets("REP")
    End If
    Set wbk = Workbooks.Add
    wbk.Worksheets(3).Delete
    wbk.Worksheets(2).Delete
    
    If CheckBox1 = True Then
        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Geloeschte Dokumente"
        Call geloeschte_Dokumente(dokneu, dokalt)
    End If
    If CheckBox2 = True Then
        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Neue Versionen von Dokumenten"
        Call neue_Versionen_Dokumente(dokneu, dokalt)
    End If
    If CheckBox3 = True Then
        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Neu hinzugefügte Dokumente"
        Call hinzugefuegte_Dokumente(dokneu, dokalt)
    End If
'    If CheckBox4 = True Then
'        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Geloeschte Artikel"
'        Call geloeschte_Artikel(repneu, repalt)
'    End If
'    If CheckBox5 = True Then
'        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Neue Versionen von Artikeln"
'        Call neue_Versionen_Artikel(repneu, repalt)
'    End If
'    If CheckBox6 = True Then
'        wbk.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Neu hinzugefügte Artikel"
'        Call hinzugefuegte_Artikel(repneu, repalt)
'    End If
    
    Unload Win
    wbk.Worksheets(1).Delete
    Application.DisplayAlerts = False
    dokneu.Parent.Close
    dokalt.Parent.Close
    wbk.SaveAs (pfad & "\Vergleich_MARA-Report.xlsx")
    Application.DisplayAlerts = True
End Sub
Sub geloeschte_Dokumente(wshneu As Worksheet, wshalt As Worksheet)
    'Gibt die Dokumente aus, die in der alten Version vorkommen, aber in der neuen fehlen
    Dim a As Long, z As Long, doknr As String, wsh As Worksheet, zelle As Range, erstezelle As String, suchbereich As Range, ergebnis As Range
    Set wsh = ActiveWorkbook.Worksheets("Geloeschte Dokumente")
    wshalt.Rows(1).Copy wsh.Rows(1)
    z = 2
    For a = 2 To wshalt.Cells(Rows.Count, 1).End(xlUp).Row
        If wshalt.Cells(a, 2).Value Like "*-*" Then
            doknr = Left(wshalt.Cells(a, 2), InStr(wshalt.Cells(a, 2), "-") - 1)
        Else
            doknr = Left(wshalt.Cells(a, 2), InStr(wshalt.Cells(a, 2), ".") - 1)
        End If
        Set zelle = wshneu.Columns(2).Find(what:=doknr, after:=wshneu.Cells(wshneu.Cells(Rows.Count, 1).End(xlUp).Row, 2))
        If zelle Is Nothing Then
            wshalt.Rows(a).Copy wsh.Rows(z)
            z = z + 1
        Else
            erstezelle = zelle.Address
            Set suchbereich = wshneu.Rows(zelle.Row)
            Do Until zelle Is Nothing
                Set zelle = wshneu.Columns(2).FindNext(after:=zelle)
                Set suchbereich = Union(suchbereich, wshneu.Rows(zelle.Row))
                If zelle.Address = erstezelle Then
                    GoTo weiter
                End If
            Loop
weiter:
            For Each cell In suchbereich
                If cell.Column = 1 And cell.Value = wshalt.Cells(a, 1).Value Then
                    Set ergebnis = cell
                End If
            Next
            If ergebnis Is Nothing Then
                wshalt.Rows(a).Copy wsh.Rows(z)
                z = z + 1
            End If
            Set ergebnis = Nothing
        End If
    Next a
    wsh.Activate
    wsh.Columns("A:D").AutoFit
End Sub
Sub neue_Versionen_Dokumente(wshneu As Worksheet, wshalt As Worksheet)
    'Gibt die Dokumente aus, die in der neuen Version einen höheren Index haben als in der alten
    Dim a As Long, b As Long, z As Long, doknr As String, wsh As Worksheet, zelle As Range
    Set wsh = ActiveWorkbook.Worksheets("Neue Versionen von Dokumenten")
    wshalt.Rows(1).Copy wsh.Rows(1)
    wsh.Columns(2).Insert
    wsh.Cells(1, 2).Value = "Dokument verlinkt - alte Version"
    wsh.Cells(1, 3).Value = "Dokument verlinkt - neue Version"
    z = 2
    For a = 2 To wshneu.Cells(Rows.Count, 1).End(xlUp).Row
        If wshneu.Cells(a, 2).Value Like "*-*" Then
            doknr = Left(wshneu.Cells(a, 2), InStr(wshneu.Cells(a, 2), "-") - 1)
        Else
            doknr = Left(wshneu.Cells(a, 2), InStr(wshneu.Cells(a, 2), ".") - 1)
        End If
        Set zelle = wshalt.Columns(2).Find(doknr)
naechste:
        If zelle Is Nothing = False Then
            If Left(wshalt.Cells(zelle.Row, 2), 13) <> Left(wshneu.Cells(a, 2), 13) And wshalt.Cells(zelle.Row, 1) = wshneu.Cells(a, 1) Then
                wshneu.Cells(a, 1).Copy wsh.Cells(z, 1)
                wshalt.Cells(zelle.Row, 2).Copy wsh.Cells(z, 2)
                wshneu.Cells(a, 2).Copy wsh.Cells(z, 3)
                wshneu.Cells(a, 3).Copy wsh.Cells(z, 4)
                wshneu.Cells(a, 4).Copy wsh.Cells(z, 5)
                z = z + 1
            End If
            Set zelle = wshalt.Range("B" & CStr(zelle.Row + 1) & ":B" & CStr(wshalt.Cells(Rows.Count, 2).End(xlUp).Row)).FindNext
            GoTo naechste
        End If
        wsh.Activate
        wsh.Columns("A:E").AutoFit
    Next a
End Sub
Sub hinzugefuegte_Dokumente(wshneu As Worksheet, wshalt As Worksheet)
    'Gibt die Dokumente aus, die nur in der neuen Version vorkommen
    Dim a As Long, z As Long, doknr As String, wsh As Worksheet, zelle As Range, erstezelle As String, suchbereich As Range, ergebnis As Range
    Set wsh = ActiveWorkbook.Worksheets("Neu hinzugefügte Dokumente")
    wshneu.Rows(1).Copy wsh.Rows(1)
    z = 2
    For a = 2 To wshneu.Cells(Rows.Count, 1).End(xlUp).Row
        If wshneu.Cells(a, 2).Value Like "*-*" Then
            doknr = Left(wshneu.Cells(a, 2), InStr(wshneu.Cells(a, 2), "-") - 1)
        Else
            doknr = Left(wshneu.Cells(a, 2), InStr(wshneu.Cells(a, 2), ".") - 1)
        End If
        Set zelle = wshalt.Columns(2).Find(what:=doknr, after:=wshalt.Cells(wshalt.Cells(Rows.Count, 1).End(xlUp).Row, 2))
        If zelle Is Nothing Then
            wshneu.Rows(a).Copy wsh.Rows(z)
            z = z + 1
        Else
            erstezelle = zelle.Address
            Set suchbereich = wshalt.Rows(zelle.Row)
            Do Until zelle Is Nothing
                Set zelle = wshalt.Columns(2).FindNext(after:=zelle)
                Set suchbereich = Union(suchbereich, wshalt.Rows(zelle.Row))
                If zelle.Address = erstezelle Then
                    GoTo weiter
                End If
            Loop
weiter:
            For Each cell In suchbereich
                If cell.Column = 1 And cell.Value = wshneu.Cells(a, 1).Value Then
                    Set ergebnis = cell
                End If
            Next
            If ergebnis Is Nothing Then
                wshneu.Rows(a).Copy wsh.Rows(z)
                z = z + 1
            End If
            Set ergebnis = Nothing
        End If
    Next a
    wsh.Activate
    wsh.Columns("A:D").AutoFit
End Sub
'Sub geloeschte_Artikel(wshneu As Worksheet, wshalt As Worksheet)
'    Dim a As Long, b As Long, z As Long, artnr As String, wsh As Worksheet, spalteneu As Integer, spaltealt As Integer
'    Dim zelle As Range, erstezelle As String, suchbereich As Range, ergebnis As Range, e As Integer
'    Set wsh = ActiveWorkbook.Worksheets("Geloeschte Artikel")
'    wshalt.Rows(1).Copy wsh.Rows(1)
'    spalteneu = 1
'    Do While wshneu.Cells(1, spalteneu).Value Like "*artikel*nummer*" = False
'        spalteneu = spalteneu + 1
'    Loop
'    spaltealt = 1
'    Do While wshalt.Cells(1, spaltealt).Value Like "*artikel*nummer*" = False
'        spaltealt = spaltealt + 1
'    Loop
'    z = 2
'    a = 2
'    b = 2
'    Do While a <= wshalt.Cells(Rows.Count, 1).End(xlUp).Row
'        If wshalt.Cells(a, spaltealt).Value = wshneu.Cells(b, spalteneu) Then
'            'überprüft, ob der Artikel revisioniert wurde - wenn nicht, wird er übersprungen
'            If wshalt.Cells(a, spaltealt + 1).Value = wshneu.Cells(b, spalteneu + 1) And wshalt.Cells(a, 2).Value > 1 Then
'                e = wshalt.Cells(a, 2).Value
'                'überspringt alles, was zu diesem Artikel gehört
'                Do While wshalt.Cells(a, 2).Value < e
'                    a = a + 1
'                Loop
'                b = a
'            else
'End Sub