Gesamtdatei splitten mittels Makro
20.04.2017 09:30:21
Marcus
ich benutze aktuell ein Makro um eine große Gesamtdatei zu splitten. Dabei verwendet das Makro den Kenner in Spalte A. Dies funktioniert grundsätzlich auch einwandfrei:
Option Explicit
Sub copyBranch()
Dim objSht As Worksheet
Dim rngAll As Range, rngKrit As Range
Dim vntTmp As Variant, vntValues As Variant
Dim lngI As Long
Dim CalculationMode As Long, UpdateLinks As Long
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
UpdateLinks = .AskToUpdateLinks
.AskToUpdateLinks = False
.DisplayAlerts = False
End With
With Sheets("Splitten")
Set rngAll = .Range("A1").CurrentRegion
rngAll.Rows(1).Copy rngAll.Cells(1, 1).Offset(0, rngAll.Columns.Count + 1)
Set rngKrit = rngAll.Cells(1, 1).Offset(0, rngAll.Columns.Count + 1).Resize(2, rngAll.Columns.Count)
End With
vntTmp = rngAll.Columns(1).Offset(1, 0).Resize(rngAll.Rows.Count - 1, 1)
vntValues = toArrayUnique(vntTmp)
For lngI = 0 To UBound(vntValues)
rngKrit.Cells(2, 1).Formula = "=""=" & vntValues(lngI) & """"
Set objSht = ThisWorkbook.Worksheets.Add
rngAll.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngKrit, _
CopyToRange:=objSht.Range("A1"), _
Unique:=False
objSht.Move
ActiveSheet.Name = Cells(1, 1) & " " & vntValues(lngI)
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & "_" & Cells(1, 1) & " " & vntValues(lngI) & ".xlsx", FileFormat:=51
ActiveWorkbook.Close
Set objSht = Nothing
Next
MsgBox "Es wurden " & UBound(vntValues) + 1 & " Dateien exportiert!"
rngKrit = ""
ErrorHandler:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copyBranch'" & vbLf & String(25, "-") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, 81968, "VBA - Fehler in Prozedur - copyBranch", .HelpFile, .HelpContext
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.AskToUpdateLinks = UpdateLinks
.CutCopyMode = False
.StatusBar = False
End With
Set rngAll = Nothing
Set rngKrit = Nothing
End Sub
Private Function toArrayUnique(Field As Variant, Optional Sort As Integer = 1) As Variant
'Sort unsortiert = 0, sortiert A-Z = 1, sortiert Z-A = -1
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = LBound(Field, 1) To UBound(Field, 1)
For lngC = LBound(Field, 2) To UBound(Field, 2)
If Not .Contains(Trim(Field(lngR, lngC))) Then
If Field(lngR, lngC) "" Then .Add Trim(Field(lngR, lngC))
End If
Next
Next
If Sort 0 Then .Sort
If Sort
toArrayUnique = .toArray
End With
Exit Function
ErrExit:
toArrayUnique = -1
End Function
Ich habe jedoch folgende Probleme:
* Wenn es ein Tabellenblatt "Hilfstabelle" gibt, dann soll das Makro dieses Tabellenblatt mit in die neue Datei kopieren ohne es zu splitten oder zu löschen. (Hintergrund: Dropdown-Hilfstabelle für Tabellenblatt 1 und Tabellenblatt 2.)
* Wenn ich ein zweites Tabellenblatt habe (das nicht Hilftabelle heisst), soll das Makro die Datei identisch splitten, wie im ersten Tabellenblatt.
Kann mir hier jm helfen?
Viele Grüße
Anzeige