Do..Until Loop stoppt mit Laufzeitfehler 1004
07.02.2019 14:07:02
Teom
hab einen Code geschrieben der Daten aus einem Datensatz in ein Template überträgt und dieses anschließend speichert. Eigentlich funktioniert alles, jedoch stoppt mein Loop nach 20 Runden mit dem Laufzeitfehler 1004, obwohl es eigentlich noch weiter gehen sollte. Der Code ist keineswegs elegant geschrieben, jedoch funktioniert er für meine Anwendung.
Sub Daten_nach_Extern()
Dim wksQ As Worksheet
Dim wkbZ As Workbook
Dim wksZ As Worksheet
Dim ZeileZ As Long
Dim strPfad As String
Dim strDatei As String
Dim s1, s2, z1 As Long
Dim wkbpath As String
Dim wkbname As String
'// array erstellen
z1 = 5
s1 = 2
s2 = 4
s3 = 5
s4 = 6
s5 = 7
s6 = 8
s7 = 9
s8 = 10
s9 = 11
s10 = 12
s11 = 13
s12 = 14
s13 = 15
s14 = 16
s15 = 17
s16 = 18
s17 = 19
Set wksQ = ActiveSheet
'Verzeichnis der Zieldatei
strPfad = "C:\Users\Teom\Desktop\Test"
'Name der Zieldatei
strDatei = "Template.xlsx"
If Dir(strPfad & "\" & strDatei) = "" Then
MsgBox "Datei " & vbLf & strPfad & "\" & strDatei & vbLf & "nicht gefunden"
Else
'//LoopStart?
Do
'//Makrobremsen fängt an zu arbeiten
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'//Zieldatei öffnen
Set wkbZ = Application.Workbooks.Open(Filename:=strPfad & "\" & strDatei)
Set wksZ = wkbZ.Worksheets("Sheet1")
With wksZ
.Cells(18, 3) = wksQ.Range(Cells(z1, s1), Cells(z1, s1)).Value
.Cells(9, 3) = wksQ.Range(Cells(z1, s2), Cells(z1, s2)).Value
.Cells(17, 3) = wksQ.Range(Cells(z1, s3), Cells(z1, s3)).Value
.Cells(19, 3) = wksQ.Range(Cells(z1, s4), Cells(z1, s4)).Value
.Cells(20, 3) = wksQ.Range(Cells(z1, s5), Cells(z1, s5)).Value
.Cells(21, 3) = wksQ.Range(Cells(z1, s6), Cells(z1, s6)).Value
.Cells(10, 3) = wksQ.Range(Cells(z1, s7), Cells(z1, s7)) & ", " & Range(Cells(z1, s8) _
, Cells(z1, s8)) & ", " & Range(Cells(z1, s9), Cells(z1, s9))
' .Cells(10, 3) = wksQ.Range(Cells(z1, s7), Cells(z1, s7)).Value
'.Cells(10, 3) = wksQ.Range(Cells(z1, s8), Cells(z1, s8)).Value
'.Cells(10, 3) = wksQ.Range(Cells(z1, s9), Cells(z1, s9)).Value
.Cells(22, 3) = wksQ.Range(Cells(z1, s10), Cells(z1, s10)).Value
.Cells(23, 3) = wksQ.Range(Cells(z1, s11), Cells(z1, s11)).Value
.Cells(24, 3) = wksQ.Range(Cells(z1, s12), Cells(z1, s12)).Value
.Cells(25, 3) = wksQ.Range(Cells(z1, s13), Cells(z1, s13)).Value
.Cells(26, 3) = wksQ.Range(Cells(z1, s14), Cells(z1, s14)).Value
.Cells(27, 3) = wksQ.Range(Cells(z1, s15), Cells(z1, s15)).Value
.Cells(28, 3) = wksQ.Range(Cells(z1, s17), Cells(z1, s17)).Value
'Gibt den Ordner an wo Datei gespeichert werden soll
ChDir ("C:\Users\Teom\Desktop\Test\TestOutput")
'ActiveWorkbook.SaveAs (z1 & ".xlsx")
ActiveWorkbook.SaveAs (Range(Cells(z1, s2), Cells(z1, s2)) & "_" & Range(Cells(z1, _
s9), Cells(z1, s9)) & "_" & Range(Cells(z1, s5), Cells(z1, s5)) & ".xlsx")
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCac
.EnableEvents = True
End With
ActiveWorkbook.Close True
z1 = z1 + 1
'Loop ende
'Gebe die letzte Zeile der Daten an
Loop Until z1 = 50
MsgBox "Ende"
End If
End Sub