Arbeitsblätter in einzelne Dateien aufteilen

Hallo zusammen,
ich habe eine Datei mit vielen Arbeitsblättern die ich per Makro regelmäßig in einzelne Dateien aufteile und unter C:\Temp abspeichere. Dazu benutze ich aktuell den folgenden Code (Dateien werden anhand des Namen des Arbeitsblatts und eines ausgelesenen Datums abgespeichert):
For Each blatt In ActiveWorkbook.Worksheets
Sheets(blatt.Name).Copy
ActiveWorkbook.SaveAs Filename:="C:\Temp\" & blatt.Name & " ab " & TEDate & ".xlsx"
ActiveWorkbook.Close
Next blatt
Das funktioniert soweit auch super. Nur habe ich das Problem, dass einige dieser einzelnen Arbeitsblätter in eine Datei gehören müssten, nämlich dann, wenn die ersten drei UND die letzten drei Stellen des Arbeitsblattnamens identisch sind. Ein Beispiel für die Arbeitsblätter in meiner großen Datei:
- 211 TGE
- 225-00 TGE
- 225-01, 02 TGE
- 229 TGE
- 236-00 TGE
- 236-01, 03 TGE
- 211 ZJE
- 225-00 ZJE
- 225-01, 02 ZJE
- 229 ZJE
- 236-00 ZJE
- 236-01, 03 ZJE
Im Moment wird jedes dieser Arbeitsblätter in einer eigenen Datei abgespeichert. Das hilft schon enorm. Allerdings gehören eigentlich "225-00 TGE" und "225-01, 02 TGE" in eine Datei sowie "225-00 ZJE" und "225-01, 02 ZJE" auch. Ich habe mehrere dieser "großen" Dateien, darum kann ich die Liste auch nicht "hart" ins Makro schreiben - eine "Erkennung", ob die ersten drei Stellen (im Beispiel 225) UND die letzten drei Stellen (TGE bzw. ZJE) mehrmals auftauchen (kann auch drei Mal sein!), wäre die beste Variante.
Die neue Datei müsste dann wiederum - im Gegensatz zum aktuellen Code, der ja nur pauschal den Arbeitsblattnamen (bspw. 225-00 TGE) nimmt - unter 225 TGE abgespeichert werden, also ohne Zusatz "00" oder "01, 02", da ja nun beide Arbeitsblätter in der Datei enthalten sind. Für alle anderen Arbeitsblätter wie bspw. 211 TGE oder 229 ZJE soll das Makro weiterhin genau das tun, was es heute tut.
Gibt es hier einen VBA-Gott, der das lösen kann? Der manuelle Aufwand das immer zusammen zu führen ist wirklich riesig :-(
Für tolle Hilfe spendiere ich gern ein Bier :-)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub aaaa() Dim i As Integer, j As Integer, objWks As Object, strWks As String, arrWks Set objWks = CreateObject("scripting.dictionary") For i = 1 To Worksheets.Count - 1 If Not objWks.exists(Sheets(i).Name) Then strWks = Sheets(i).Name objWks(Sheets(1).Name) = 0 For j = i + 1 To Worksheets.Count If Not objWks.exists(Sheets(j).Name) Then If Left(Sheets(j).Name, 3) = Left(Sheets(i).Name, 3) _ And Right(Sheets(j).Name, 3) = Right(Sheets(i).Name, 3) Then strWks = strWks & "|" & Sheets(j).Name objWks(Sheets(j).Name) = 0 End If End If Next arrWks = Split(strWks, "|") Sheets(arrWks).Copy With ActiveWorkbook If UBound(arrWks) > 0 Then .SaveAs "c:\test\" _ & Left(arrWks(0), 3) & " " _ & Right(arrWks(0), 3) & " ab " _ & Format(Date, "YYYYMMDD") Else .SaveAs "c:\test\" & arrWks(0) & " ab " _ & Format(Date, "YYYYMMDD") End If .Close End With End If Next End Sub

If UBound(arrWks) > 0 Then .SaveAs "c:\test\" _ & Left(arrWks(0), 3) & " " _ & Right(arrWks(0), 3) & " ab " _ & Format(Date, "YYYYMMDD") Else .SaveAs "c:\test\" & arrWks(0) & " ab " _ & Format(Date, "YYYYMMDD") End If

If UBound(arrWks) > 0 Then .SaveAs "c:\test\xxxxx " & Right(arrWks(0), 3) &"\" _ & Left(arrWks(0), 3) & " " _ & Right(arrWks(0), 3) & " ab " _ & Format(Date, "YYYYMMDD") Else .SaveAs "c:\test\" & arrWks(0) & " ab " _ & Format(Date, "YYYYMMDD") End If

Hallo Rudi,
tut mir leid, aber ich glaube ich drücke mich falsch aus.
Dein ursprünglicher Code sorgt dafür, dass die Arbeitsblätter 211 TGE und 211 ZJE einfach nur per Blattname + ab YYYYMMDD.xlsx in jeweils einer neuen Datei gespeichert werden, weil es 211 TGE und 211 ZJE nur ein Mal in der Ursprungsdatei gibt.
Die Arbeitsblätter 225-00 TGE und 225-01, 02 TGE dagegen werden gemeinsam als 225 TGE in einer Datei abgespeichert sowie 225-00 ZJE und 225-01, 02 ZJE als 225 ZJE, weil es eben 225...TGE und 225...ZJE in der Ursprungsdatei jeweils zwei Mal gibt.
Sprich der Code unterscheidet, ob er für den Dateinamen platt den Arbeitsblattnamen verwendet oder nur die ersten drei Stellen des Arbeitsblattnamens (225) und ob er, wenn etwas doppelt auftaucht, das in eine Datei packt. Soweit auch richtig und super.
Wenn ich aber in diesem Code den Pfad anpasse, erreiche ich nur, dass die Dateien, wo zum speichern 1:1 der Blattname verwendet wurde (211 TGE und 211 ZJE) in Pfad A landen und die Dateien, wo nur die ersten drei Ziffern für den Dateinamen verwendet wurden (225 TGE und 225 ZJE) in Pfad B. Ich möchte aber 211 TGE und 225 TGE in einem Ordner sowie 211 ZJE und 225 ZJE gemeinsam in einem anderen Ordner.
Ich hoffe ich konnte es verständlich machen!

Sub aaaa() Dim i As Integer, j As Integer, objWks As Object, strWks As String, arrWks Dim strFolder As String, strSubFolder As String strFolder = "c:\test\" 'Grundordner Set objWks = CreateObject("scripting.dictionary") Application.ScreenUpdating = False For i = 1 To Worksheets.Count - 1 If Not objWks.exists(Worksheets(i).Name) Then strWks = Worksheets(i).Name objWks(Worksheets(1).Name) = 0 For j = i + 1 To Worksheets.Count If Not objWks.exists(Worksheets(j).Name) Then If Left(Worksheets(j).Name, 3) = Left(Worksheets(i).Name, 3) _ And Right(Worksheets(j).Name, 3) = Right(Worksheets(i).Name, 3) Then strWks = strWks & "|" & Worksheets(j).Name objWks(Worksheets(j).Name) = 0 End If End If Next arrWks = Split(strWks, "|") Worksheets(arrWks).Copy strSubFolder = strFolder & Right(arrWks(0), 3) & "\" 'TGE oder ZJE anhängen With ActiveWorkbook If UBound(arrWks) > 0 Then 'mehrere Blätter .SaveAs strSubFolder _ & Left(arrWks(0), 3) & " " _ & Right(arrWks(0), 3) & " ab " _ & Format(Date, "YYYYMMDD") Else 'nur 1 Blatt .SaveAs strSubFolder _ & arrWks(0) & " ab " _ & Format(Date, "YYYYMMDD") End If .Close End With End If Next End Sub

Sub test() Dim WB As Workbook Dim Nme As String Dim Blatt As Worksheet For Each Blatt In ActiveWorkbook.Worksheets Nme = Left(Blatt.Name, 3) & " " & Right(Blatt.Name, 3) & " ab " & Format(TEDate, "YYYY-MM- _ DD") Set WB = Nothing On Error Resume Next Set WB = Worksheets(Nme & ".xlsx") On Error GoTo 0 If WB Is Nothing Then Set WB = Worksheets.Add(xlWBATWorksheet) Blatt.Copy after:=WB.Worksheets(1) Application.DisplayAlerts = False WB.Worksheets(1).Delete Application.DisplayAlerts = True WB.SaveAs Filename:="C:\Temp\" & Nme, FileFormat:=xlOpenXMLWorkbook Else Blatt.Copy after:=WB.Worksheets(WB.Worksheets.Count) WB.Save End If Next Blatt For Each WB In Application.Workbooks If WB.FullName Like "C:\Temp\*" Then WB.Close False Next End Sub

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter in einzelne Dateien aufteilen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

44 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter in einzelne Dateien aufteilen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

44 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread