Excel Absturz während Speichervorgang
17.12.2013 19:04:43
Marvin
ich habe es endlich geschafft mein Makro soweit zu vervollständigen, dass es mehrere Excel Dateien öffnet, alle benötigten Seiten aus den einzelnen Dateien in einer Datei zusammenfasst und am Ende nur noch die benötigte Seite übrig bleibt und der Rest ohne zu speichern geschlossen wird.
Beim Letzten Schritt taucht nun aber ein Problem auf. Im Prinzip soll die Datei über den Befehl "Speichern unter" einfach nur in ein anderes Verzeichnis abgespeichert werden, um die ursprüngliche Vorlage zu erhalten. Die Programmierung in VBA schien mir auch nicht besonders schwer, allerdings tritt jedes mal beim Speichervorgang ein Fehler auf und Excel wird beendet und startet anschliessend die "reparierte" Datei neu. Der selber Fehler tritt auch auf, wenn ich den Speichervorgang ohne Makro manuel abschliessen möchte. Wenn ich allerdings eine von den insgesamt 9 Seiten aus dem Dokument entferne tritt der Fehler nicht auf, ich weiss nicht woran es liegen kann. Die finale Datei ist dabei gerade mal ca. 700kb gross.
Vielen Dank für die Unterstützung!
Hier ist der Quellcode, vielleicht bringt der zusätzlich etwas Klarheit:
'Alle Excel-Dateien im Ordner Modelle\"Modell" öffnen, sowie alle Excel-Dateien im Ordner _ Modelle öffnen
Sub DateienÖffnen()
Dim strDatei As String
Dim strKalenderwoche As String
Dim strPfad As String
strKalenderwoche = Application.InputBox("Bitte geben Sie die aktuelle Kalenderwoche ein.")
strPfad = "C:\Test\Test\Test\Test\13_KW " & strKalenderwoche & "\Modelle\Test\"
strDatei = Dir(strPfad & "*.xls*")
Sheets("Verteiler").Select
Range("C9:F9").Select
ActiveCell.FormulaR1C1 = "KW " & strKalenderwoche & "/2013"
Do While strDatei ""
Application.Workbooks.Open strPfad & strDatei
strDatei = Dir()
Loop
strPfad = "C:\Test\Test\Test\Test\13_KW " & strKalenderwoche & "\Modelle\"
strDatei = Dir(strPfad & "*.xls*")
Do While strDatei ""
Application.Workbooks.Open strPfad & strDatei
strDatei = Dir()
Loop
Windows.Arrange ArrangeStyle:=xlTiled
'Fenster in Reihenfolge sortieren und schliessen ohne zu speichern
Windows("Test.xls").Activate
Sheets("Typ 1) ZP5 ").Select
Sheets("Typ 1) ZP5 ").Move After:=Workbooks("Typ_ Test.xls").Sheets( _
2)
Windows("Test").Activate
Sheets("Typ 2) Test").Select
Sheets("Typ 2) Test").Move After:=Workbooks("Typ_ Test.xls").Sheets( _
3)
Windows("Test.xls").Activate
Sheets("Test").Select
Sheets("Test").Move After:=Workbooks( _
"Typ_ Test.xls").Sheets(4)
Windows("Test.xlsx").Activate
Sheets("Test").Select
Sheets("Test - 5) Test").Move After:=Workbooks( _
"Typ_ Test.xls").Sheets(5)
Windows("Test.xls").Activate
Sheets("Typ 6) ZP7").Select
Sheets("Typ 6) ZP7").Move After:=Workbooks("Typ_ Test.xls").Sheets(6 _
)
Windows("Test.xlsx").Activate
Sheets("Typ 6) Test ZP8 ").Select
Sheets("Typ 6) Test ZP8 ").Move After:=Workbooks("Typ_ Test.xls"). _
Sheets(7)
Windows("Test.xls").Activate
Sheets("VW 325 7) ZP8 Test").Select
Sheets("VW 325 7) ZP8 Test").Move After:=Workbooks("Typ_ Test.xls") _
.Sheets(8)
Windows("Test.xls").Activate
Sheets("Test 7) ZP8 Test (2)").Select
Sheets("Test 7) ZP8 Test (2)").Move After:=Workbooks( _
"Typ_ Test.xls").Sheets(9)
Windows("Test KW" & strKalenderwoche & ".xlsx").Activate
ActiveWindow.Close savechanges:=False
Windows("Test_KW " & strKalenderwoche & "_2013.xls").Activate
ActiveWindow.Close savechanges:=False
Windows("Test KW" & strKalenderwoche & ".xlsx").Activate
ActiveWindow.Close savechanges:=False
Windows("Test " & strKalenderwoche & ".xls").Activate
ActiveWindow.Close savechanges:=False
Windows("Test " & strKalenderwoche & ".xls").Activate
ActiveWindow.Close savechanges:=False
Windows("Test" & strKalenderwoche & "_Test.xls").Activate
ActiveWindow.Close savechanges:=False
Windows("Test" & strKalenderwoche & "_Test.xls").Activate
ActiveWindow.Close savechanges:=False
ActiveWindow.WindowState = xlMaximized
'Button löschen
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Verteiler").Select
ActiveSheet.Shapes("Button 13").Select
Selection.Delete
'Im anderen Verzeichnis speichern, um Vorlage zu erhalten
ChDir "C:\Test\Test\Test\Test\13_KW " & strKalenderwoche & ""
ActiveWorkbook.SaveAs Filename:= _
"C:\Test\Test\Test\Test\13_KW " & strKalenderwoche & "\Typ_ Test.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
Grüsse
Marvin