|
Hallo allerseits!
Ich habe ein Problem und hoffe hier die Antwort darauf zu finden.
Ich habe eine Excel Datei, welche ein Makro enthält. Aufgabe des Makros ist es, 2 Tabellen, in denen Dateien aufgelistet sind, zu analysieren und die Unterschiede auszuwerten. D.h.: Ich kann die alte und die neue Version einer Datei wählen und dann wird mir die Differenz, also die Dokumente die seit der letzten Version dazugekommen sind, angezeigt.
Bis hier her funktioniert ja alles.
Das Problem ist jedoch dass das Makro ca. einen halben Tag läuft bis ein Ergebnis präsentiert wird.
Ich schätze das liegt am Suchalgorithmus. Habe einen anderen gefunden doch ich weis nicht wie ich ihn einbauen kann. Ich habe nichts von all dem selber geschrieben. Hab es so bekommen, doch das ist echt kein Stand mit dem man arbeiten kann.
Ich hoffe dass ich mich so ausgedrückt habe, dass mein Problem verständlich für euch ist.
Code:
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
Das ist der Code, welchen es zu verbessern gilt. Checkbox 4 bis 6 sind momentan noch ohne Funktion. Bei den anderen muss der Suchalgorithmus so verbessert werden, dass sich die Laufzeit stark verkürzt.
Bei Fragen stehe ich natürlich zu Verfügung |