Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro Subsplit über mehrere Tabellenblätter

Makro Subsplit über mehrere Tabellenblätter
26.02.2018 14:18:48
Tommy
Liebe Excel Profis,
ich benötige Eure Unterstützung beim Aufteilen einer Excel Datei mit mehreren Tabellenblättern mittels Makro.
Die Masterdatei enthält 3 Tabellenblätter (FX, TG & WP). Die Spalte D "Split-Kriterim" beinhaltet das Kriterium, nachdem die einzelnen Datensätze aufgeteilt werden sollen (in jedem Tabellenblatt).
Als Resultat soll für jedes Split-Kriterium eine neue Excel Datei mit jeweils 3 Tabellenblättern erscheinen.
Masterdatei:
https://www.herber.de/bbs/user/120072.xlsx
Viele Grüße
Tommy

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro Subsplit über mehrere Tabellenblätter
26.02.2018 14:37:34
Daniel
Hi
ok, du brauchst Unterstützung.
was sind denn deine konkreten Fragen?
Bei welchen Punkten hast du Probleme?
Oder möchtest du einfach einen fertigen Code geliefert bekommen?
Gruß Daniel
AW: Makro Subsplit über mehrere Tabellenblätter
26.02.2018 19:08:13
Tommy
Hi Daniel,
am liebsten hätte ich gerne einen fertigen Code, da meine VBA Kenntnisse leider sehr schlecht sind.
Beste Grüße
Tommy
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
Anzeige

369 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige