Tja, mein Lieber das klingt jetzt im 2. Anlauf auch ein wenig anders.
Kein Wunder, wenn Attribute wie "z.B." oder vage Dateibezeichnungen im Spaghetti-Fließtext mitschwimmen
(da kann manch ein freundlicher Helfer auch schnell A mit B verwechseln).
Und ich habe daher schon erstmals den Kopiervorgang außen vor gelassen.
Nun sieht die Sache schon informativer aus, daher könnte man(n) es so lösen.
LG
Option Explicit
'aus dem Registerblatt "Export"
'nacheinander 100 Zeilen (im Bereich B2 bis BE101,
'anschließend B102 bis BE201, dann B202 bis BE301 usw
'markiert und kopiert werden
'
'diese 100 Zeilen jeweils in eine bestehende Excelmappe (.xls) ab Zelle B2 i
'ab Zelle B2 in Registerblatt "Übersicht" als Werte eingefügt
'unter separaten Namen abgespeichert
' namentlich fortlaufend z.B. "Fertig_Datei_1.xls", "Fertig_Datei_2.xls", usw.
'
Dim oShS As Excel.Worksheet 'unsere "Quelle" in der Makro Arbeitsmappe
Dim oWbk As Excel.Workbook 'die Zielvorlage - Arbeitsmappe
Dim oShT As Excel.Worksheet 'das Zielvorlage - Arbeitsblatt
'
Sub SoSo()
Dim x As Long, y As Long, z As Long
Dim rngS As Range 'Qell- und Teildatenbereich
'
'Vorgaben
Const C_Sourc As String = "Export"
Const C_First As String = "B2"
Const C_LastC As String = "BE"
'
Const C_Step As Long = 100
'
Const C_Pfad As String = "E:\VBA\Test.xlsx" 'anpassen
Const C_Targ As String = "Übersicht"
Const C_Cell As String = "B2"
'
Const C_NewN As String = "E:\VBA\Fertig_Datei_XYZ.xlsx" 'anpassen
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo JErr
'Zuweisung
Set oShS = ThisWorkbook.Worksheets(C_Sourc)
With oShS
'letzte Zeile und Datenbereich
z = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row
Set rngS = Range(.Range(C_First), .Columns(C_LastC).Cells(z))
End With
For x = 1 To z Step C_Step
'verwenden immer gleiche Vorlage
Set oWbk = Workbooks.Open(C_Pfad)
Set oShT = oWbk.Worksheets(C_Targ)
'Quellblock kopieren
rngS.Rows(x).Resize(C_Step).Copy
oShT.Range(C_Cell).PasteSpecial (xlPasteValues)
y = y + 1
oWbk.SaveAs _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False, _
Filename:=Replace(C_NewN, "XYZ", Format(y, "0"))
oWbk.Close False
Set oWbk = Nothing
Next x
On Error GoTo 0
JErr:
If Err.Number > 0 Then
If Not oWbk Is Nothing Then
On Error Resume Next
oWbk.Close False
Set oWbk = Nothing
End If
Call MsgBox("prüfe die Makrovorgaben", vbExclamation, "Fehler aufgetreten")
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set oShS = Nothing
End Sub
|