Thema Datum  Von Nutzer Rating
Antwort
Rot Optimierung des Excel VBA - Laufzeitfehler 1004
 10.12.2012 12:27:13 Matthias
NotSolved

Ansicht des Beitrags:
Von:
Matthias		 Datum:
10.12.2012 12:27:13		 Views:
2432		 Rating:
     
Antwort:
  Ja
Thema:
Optimierung des Excel VBA - Laufzeitfehler 1004

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

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
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

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Optimierung des Excel VBA - Laufzeitfehler 1004
 10.12.2012 12:27:13 Matthias
NotSolved