Option
Explicit
Sub
TryIt()
Const
TITEL =
"Marke"
Const
ENDUNG =
".xlsx"
Dim
oWbk
As
Workbook
Dim
oWsh
As
Worksheet
Dim
Arr()
As
Variant
Dim
x
As
Long
Dim
c
As
Range
Dim
strName
As
String
Dim
lngSpalte
As
Long
Application.ScreenUpdating =
False
ThisWorkbook.ActiveSheet.Copy
Set
oWbk = ActiveWorkbook
Set
oWsh = oWbk.ActiveSheet
lngSpalte = ThisWorkbook.ActiveSheet.Rows(1).Find(TITEL).Column
oWsh.Cells.RemoveDuplicates Columns:=lngSpalte, Header:=xlYes
Arr = oWsh.Range(Cells(1, lngSpalte), Cells(1, lngSpalte).
End
(xlDown))
oWsh.Cells.Clear
ThisWorkbook.Activate
lngSpalte = 0
For
Each
c
In
Range(ActiveSheet.UsedRange.Rows(1).Address)
lngSpalte = lngSpalte + 1
If
c.Value = TITEL
Then
Exit
For
Next
c
Application.DisplayAlerts =
False
ActiveSheet.UsedRange.AutoFilter
For
x = LBound(Arr) + 1
To
UBound(Arr)
ActiveSheet.UsedRange.AutoFilter Field:=lngSpalte, Criteria1:=Arr(x, 1)
ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=oWsh.Cells(1, 1)
strName = Trim(Arr(x, 1))
strName = Replace(ThisWorkbook.FullName, _
ThisWorkbook.Name, strName & ENDUNG)
oWbk.SaveAs strName
oWsh.Cells.Clear
Next
x
ActiveSheet.Cells.AutoFilter
oWbk.Close savechanges:=
False
Application.DisplayAlerts =
True
Application.ScreenUpdating =
True
End
Sub