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 :-)

Hallo,
also alle TGE in einen Ordner und alle ZJE in einen Ordner!
Bedingung: Alle Blätter enden auf TGE oder ZJE und die Ordner existieren.

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

Gruß
Rudi

Arbeitsblätter in einzelne Dateien aufteilen

Forumthread: Arbeitsblätter in einzelne Dateien aufteilen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial