Hallöchen,

habe ein Problem mit nem Makro. Sobald es gestartet wird, erscheint (nicht immer) "Laufzeitfehler 1004"

Das Makro ist wahrscheinlich total schlecht geschrieben, aber hat bis jetzt immer seinen Dienst getan.

Kann mir jemand sagen wo der Fehler sitzt, oder was man optimieren könnte.

Vieln Dank schonmal im voraus

Option Explicit
Dim xPfad, xDateiNam As String
Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
'\\Werkstatt-rad\werkstattzettel\Verkaufsbeleg.xls
Public Sub Uebernehmen()
'Daten von Dateneingabe nach Kundenbeleg und Adressdatenbank übernehmen   FUNZT
Dim WkSh_Q    As Worksheet
Dim WkSh_Z    As Worksheet
Dim lZeile_Q  As Long
Dim lZeile_Z  As Long
Dim iSpalte   As Integer
Application.ScreenUpdating = False
Set WkSh_Q = ThisWorkbook.Worksheets("Dateneingabe")
Set WkSh_Z = ThisWorkbook.Worksheets("Addressdatenbank")
lZeile_Z = WkSh_Z.Cells(Rows.Count, 1).End(xlUp).Row + 1
iSpalte = 0
For lZeile_Q = 1 To WkSh_Q.Cells(Rows.Count, 1).End(xlUp).Row
If WkSh_Q.Range("B" & lZeile_Q).Value <> "" Then
iSpalte = iSpalte + 1
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = WkSh_Q.Range("B" & lZeile_Q).Value
End If
Next lZeile_Q
Application.ScreenUpdating = True
Sheets("Addressdatenbank").Cells.Columns.AutoFit
'Sheets("Dateneingabe").Select
'Sicherungkopie der Adressdatenbank wird auf Laufwerk C:\ erstellt.
Dim Datname
Datname = Cells(1, 8).Value
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Sheets("Addressdatenbank").Copy     ??????????ß
'------------------------------------------------------------------------------------------------------------------
'Cells.Select
'Cells.Copy
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
'xlNone, SkipBlanks:=False, Transpose:=False
'Cells(1, 1).Select
'ActiveWorkbook.SaveAs Filename:= _
'"d:\Verkaufsbelege\Kundendaten\" & Datname & "Kundendaten ab 2010" & " " & Format(Now, "dd.mm.yyyy hh_mm_ss") & ".xls", FileFormat:=xlNormal, _
'Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
'CreateBackup:=False
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
'ActiveWindow.Close
'Dim Datname
'Datname = Cells(1, 8).Value
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False


'------------------------------------------------------------------------------
Sheets("Addressdatenbank").Copy

'Sheets("Kundenbeleg").Select
Cells.Select
Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Cells(1, 1).Select

ActiveWorkbook.SaveAs Filename:= _
"K:\" & Datname & "Kundendaten ab 2010" & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

'ActiveWorkbook.SaveAs Filename:= _
'"D:\Radsport\Werkstatt\Kundendatei\" & Datname & "Kundendaten ab 2010" & ".xls", FileFormat:=xlNormal, _
'Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
'CreateBackup:=False

Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWindow.Close
'Dim Datname
'Datname = Cells(1, 8).Value
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
'Sheets("Addressdatenbank").Copy
'Cells.Select
'Cells.Copy
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
'xlNone, SkipBlanks:=False, Transpose:=False
'Cells(1, 1).Select
'ActiveWorkbook.SaveAs Filename:= _
'"K:\" & Datname & "Kundendaten ab 2010" & ".xls", FileFormat:=xlNormal, _
'Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
'CreateBackup:=False
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
'ActiveWindow.Close
'D:\Radsport\Werkstatt\Kundendatei\
'----------------------------------------------------PDF Datei wird erstellt!!!
Dim pdfjob As Object
Dim sPDFName As String
Dim sPDFPath As String
Dim LngCounter As Long
'Dim strText As String
Dim objShell
Application.DisplayFullScreen = True
Sheets("Kundenbeleg").Select
sPDFName = Cells(100, 1).Value
sPDFPath = "D:\Verkaufsbelege\"
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
'--------------------------------------------------------
Application.StatusBar = "pdf in Arbeit..."
'--------------------------------------------------------
Debug.Print "PrintToPDF, Printing "; sPDFPath & sPDFName
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
Debug.Print "PrintToPDF, init Printing"
With pdfjob
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Can't initialize PDFCreator.", vbCritical + _
vbOKOnly, "PrtPDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sPDFPath
.cOption("AutosaveFilename") = sPDFName
.cOption("AutosaveFormat") = 0    ' 0 = PDF
.cClearCache
End With
Debug.Print "PrintToPDF, Start Printing"
ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"
LngCounter = 0
Do Until pdfjob.cCountOfPrintjobs = 1
Debug.Print "PrintToPDF, Waiting for Printjob = 1:"; LngCounter
Sleep 100
DoEvents
LngCounter = LngCounter + 1
Loop
pdfjob.cPrinterStop = False
LngCounter = 0
Do Until pdfjob.cCountOfPrintjobs = 0
Debug.Print "PrintToPDF, Waiting for Printjob = 0:"; LngCounter
Sleep 100
DoEvents
LngCounter = LngCounter + 1
Loop
Debug.Print "PrintToPDF, Closing"
'Application.Wait Now() + TimeSerial(0, 0, 5)
pdfjob.cClose
Set pdfjob = Nothing
Debug.Print "PrintToPDF, Done."
Sleep 100
DoEvents
Set objShell = CreateObject("WScript.Shell")
objShell.PopUp "Daten digital gespeichert... Druck startet Jetzt", 1, "Information", _
vbInformation                        ' 1 Sekunden
Set objShell = Nothing
'strText = " Daten digital hinterlegt... jetzt drucken !!!"
'MsgBox strText
Sleep 200
DoEvents
'----------------------------------------------------
Application.StatusBar = False 'Steuerung zurück an Excel!
'-----------------------------------------------------
'----------------------------------Quittung wird gedruckt
'----------------------------------Drucker Werkstatt
Application.ActivePrinter = "Canon iP3600 auf Ne01:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"Canon iP3600 auf Ne01:", Collate:=True
'-----------------------------------Drucker Büro
'Application.ActivePrinter = _
'"\\RADSPORT-BUERO\Canon MX700 series Printer auf Ne02:"
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
'"\\RADSPORT-BUERO\Canon MX700 series Printer auf Ne02:", Collate:=True
'----------------------------------Pivottabellen aktualisieren!
Sheets("verkauftebikes").Select
Range("E16").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
'Sheets("Herstelleranteile").Select
'Range("A2").Select
'ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
'Sheets("Umsätze").Select
'Range("A2").Select
'ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
'----------------------------------Alles löschen
Sheets("Dateneingabe").Select
'----------------------------------Kopiert die Adressdaten für Adressübernahme
Range("B2:B8").Select
Selection.Copy
Sheets("Admin").Select
Range("J1").Select
ActiveSheet.Paste
'-----------------------------------------------------------------------------
Sheets("Dateneingabe").Select
'Range("B1") = HEUTE()
Sheets("Admin").Select
Range("J11").Select
Selection.Copy
Sheets("Dateneingabe").Select
ActiveSheet.Unprotect
Range("B6").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'Range("B1") = "=HEUTE()"
Range("B2") = "-"
Range("B3") = "-"
Range("B4") = "-"
Range("B5") = "0"
Range("B7") = "-"
Range("B8") = "-"
Range("B10:B22") = "-"
'Range("B11") = "-"
'Range("B12") = "-"
'Range("B13") = "-"
'Range("B14") = "-"
'Range("B15") = "-"
'Range("B16") = "-"
'Range("B17") = "-"
'Range("B18") = "-"
'Range("B19") = "-"
'Range("B20:B22") = "-"
Range("B24") = "-"
Range("B25") = "-"
Range("B26") = "-"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("B20:B22").Select
Sheets("START").Select
Sheets("Umsätze").Select
Sheets("verkauftebikes").Select
Sheets("START").Select
ActiveWorkbook.Save
'----------------------------------TEST
'Sub SicherungsKopie()
xPfad = "c:\" 'Wohin speichern?
xDateiNam = "Umsätze.xls"
Sheets(Array("Umsätze", "verkauftebikes")).Copy
'Sheets("Abrechnung").Copy ' Kopiert das Blatt (Blätter) in eine neue Arbeitsmappe
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xPfad & xDateiNam
ActiveWindow.Close 'Schliesst die kopierte/gespeicherte Arbeitsmappe
'End Sub
ActiveWorkbook.Save
End Sub