Gruppe
Datei
Problem
Die Werte aus den Spalten A:C sollen je Filiale in gesonderten Arbeitsmappen in dem in Zelle G1 genannten Verzeichnis gespeichert werden.
StandardModule: Modul1
Sub FilialenSpeichern()
Dim rng As Range
Dim col As New Collection
Dim iRow As Integer
Dim sFile As String
Application.ScreenUpdating = False
iRow = 2
sFile = Range("G1").Value
On Error Resume Next
Do Until IsEmpty(Cells(iRow, 1))
col.Add Cells(iRow, 1).Value, Cells(iRow, 1).Value
iRow = iRow + 1
Loop
On Error GoTo 0
Application.DisplayAlerts = False
For iRow = 1 To col.Count
Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=col(iRow)
Set rng = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
Workbooks.Add
rng.Copy Range("A1")
ActiveWorkbook.SaveAs sFile & "\" & col(iRow) & ".xls"
ActiveWorkbook.Close savechanges:=True
Next iRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.AutoFilterMode = False
MsgBox "Job erledigt!"
End Sub