AW: Makro Subsplit über mehrere Tabellenblätter
04.03.2018 12:14:16
Dieter
Hallo Tommy,
ich bin davon ausgegangen, dass in den einzelnen Blättern - wie in deiner Beispieldatei - gleiche Satzzahlen für die verschiedenen Kriterien vorhanden sind. Dann könnte das Programm z.B. so aussehen
Sub Trennen()
Dim aktSplitKrit As String
Dim anfZeile As Long
Dim datName As String
Dim endZeile As Long
Dim i As Long
Dim letzteZeile As Long
Dim pfad As String
Dim sinw As Long
Dim sortBereich As Range
Dim wb As Workbook ' Neu erzeugte Mappe
Dim wbM As Workbook ' Master
Dim ws As Worksheet
Dim wsFX As Worksheet ' Blatt "FX" vom Master
Dim wsM As Worksheet ' Blatt vom Master
Dim zeile As Long
' Application.ScreenUpdating = False
sinw = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
Set wbM = ThisWorkbook
pfad = wbM.Path & "\"
Set wsFX = wbM.Worksheets("FX")
letzteZeile = wsFX.Cells(wsFX.Rows.Count, "A").End(xlUp).Row
If letzteZeile aktSplitKrit Then
' Wechsel des SplitKriteriumn
endZeile = zeile - 1
Set wb = Workbooks.Add
For i = 1 To 3
Set ws = wb.Worksheets(i)
Set wsM = wbM.Worksheets(i)
ws.Name = wsM.Name
wsM.Rows("1:3").Copy Destination:=ws.Rows("1:3")
wsM.Range(wsM.Rows(anfZeile), _
wsM.Rows(endZeile)).Copy Destination:=ws.Range("A4")
ws.Columns.AutoFit
Next i
datName = aktSplitKrit & ".xlsx"
Application.StatusBar = datName
On Error Resume Next
Workbooks(datName).Close SaveChanges:=False
On Error GoTo 0
Application.DisplayAlerts = False
wb.SaveAs Filename:=pfad & datName
Application.DisplayAlerts = True
wb.Close
anfZeile = endZeile + 1
If Not IsEmpty(wsFX.Cells(anfZeile, "D")) Then
aktSplitKrit = wsFX.Cells(anfZeile, "D")
Else
Exit For
End If
End If
Next zeile
Application.SheetsInNewWorkbook = sinw
Application.ScreenUpdating = True
Application.StatusBar = Empty
End Sub
Viele Grüße
Dieter
https://www.herber.de/bbs/user/120201.xlsm