' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
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("Tabelle1")
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
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Niederlassung_" & 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 < 0 Then .Reverse
toArrayUnique = .toArray
End With
Exit Function
ErrExit:
toArrayUnique = -1
End Function