Unerklärliche Abstürze
30.05.2016 23:41:26
Robert
nachdem ich letzte Woche durch das Forum einen super Tipp bekommen habe mein Makro entscheidend zu verbessern wende ich mich heute mit einem neuen Problem an euch.
Das Makro ist etwas umfangreicher geworden und ich muss daher leider unwesentliche Passagen heraus kürzen. Das Problem stellt sich wie folgt dar:
Das Makro läuft komplett durch und die letzte MessageBox wird angezeigt. Nun hat man die _ gespeicherte Ergebnisdatei vor sich, wenn ich die jetzt beende stürzt Excel ab, aber eben auch nicht immer. Manchmal klappen 10 Versuche hintereinander, manchmal klappen 5 nacheinander nicht. Ich habe auch das Gefühl, ich kann die Abstürze voraus sagen, weil das Makro dann länger durchläuft als gewöhnlich...merkwürdig. Vielleicht hat jemand einen Tipp! Ich habe schon alles ausprobiert /auskommentiert und komme nicht mehr weiter.
Sub NOW_Makro()
ThisWorkbook.Save
'---Gegen das Flackern-----------------------------------------------------------
Application.ScreenUpdating = False
'Application.EnableEvents = True
'---Zieldatei öffnen und kopieren------------------------------------------------
'---Quelle, aus der die Tabelle kopiert werden soll
datei_quelle = Application.GetOpenFilename("Excel-Dateien(*.xl*),*.xl*")
If datei_quelle = False Then Exit Sub
Set QWB = Workbooks.Open(Filename:=datei_quelle, ReadOnly:=True)
'---Inhalt in Ziel-Tabelle einfügen
QWB.Worksheets(1).Cells.copy Workbooks("Programm_VOC_NOW.xlsm").Worksheets(2).Cells(1, 1)
'---Quelldatei schließen
QWB.Close
'---NOW Tabelle expandieren um alle nicht gefundenen und angefügten Elemente mit einzubeziehen-- _
_
ActiveSheet.ListObjects(1).Resize Range("B3", Cells(i, 8))
'---Dateiname einfügen und speichern---------------------------------------------
dateiname = ThisWorkbook.Worksheets(1).Cells(1, 3)
'---Buttons löschen----------------------------------------------------------------------------- _
_
ThisWorkbook.Worksheets(1).Shapes.SelectAll
Selection.Delete
'Cells(1, 1).Select
'---Fertig - jetzt speichern!----------------------------------------------------
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(2).Delete
'---Ohne Makros speichern und sind leere Zeilen gelöscht ja/nein mit in
ThisWorkbook.SaveAs Filename:=dateiname & " Analyse " & leerezeilen, FileFormat:= _
xlOpenXMLWorkbook
'---Warnungen wieder anschalten--------------------------------------------------
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
'---QS Projektnummer in Txt schreiben----------------------------------------------------------- _
_
_
On Error Resume Next
If Dir(path) = "" Then
Open path For Output As #1
Close #1
End If
Open path For Append As #1
Print #1, dateiname & " " & Format(Now, "dd.mm.yyyy") & " " & Format(Now, "hh:mm") & " " & _
Environ("Username") & " " & version
Close #1
'---Finale Informationsausgabe---------------------------------------------------
MsgBox "Analyse erfolgreich beendet!" & vbNewLine & vbNewLine & _
"Importiert und gespeichert unter:" & vbNewLine & vbNewLine & _
" - " & dateiname & " Analyse " & leerezeilen & ".xlsx" & vbNewLine & vbNewLine & vbNewLine & _
"Statistik:" & vbNewLine & _
gefunden & " Übereinstimmungen" & vbNewLine & _
ueberschreitung & " Grenzwertüberschreitungen" & vbNewLine & _
nichtgefunden & " Nicht identifizierbare Elemente", vbInformation, version
End Sub