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
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)
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)
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)
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