< Ich hoffe ich habe mich so ausgedrückt, dass

Hi Udo,

> ich auch ;)

anbei eierlegendewollmilch zum als Ansatz zum Selbststudium

Frohes Fest

'******************************************************************************
' Modul: mdl_TryIt / erstellt :
'------------------------------------------------------------------------------
' Zweck / Inhalt :
' je ein neues WB vom akt. Tabelle nach Marke
'******************************************************************************

Option Explicit

Sub TryIt()
'
'******************************************************************************
' Name : TryIt / erstellt :
'------------------------------------------------------------------------------
'akt. Tabelle hat Überschrift Zeile 1 mit "Marke"
'Markenspalte festlegen
'aktuelle Tabelle als Kopie
'in Kopie Markenspalte / Duplikaten weg / in Datenfeld merken
'Kopie leeren
'Original mit Markennamen aus Datenfeld filtern
'Filter in Kopie schreiben und mit Markennamen speichern
'Kopie schließen
'******************************************************************************
'
'anpassen
Const TITEL = "Marke"                        'Sortierbegriff
Const ENDUNG = ".xlsx"                       'Excel Dateiformat
'
Dim oWbk As Workbook                         'Duplikat Mappe
Dim oWsh As Worksheet                        'Duplikat Tabelle
Dim Arr() As Variant                         'Datenfeld für Marken
Dim x As Long                                'Datenfeld Zähler
Dim c As Range                               'Zellen zählen
Dim strName As String                        'Dateiname(n)
Dim lngSpalte As Long                        'Spalte Sortierbegriff u. Datenfeld
                                             'und suchen
Application.ScreenUpdating = False           'ohne Anzeige
ThisWorkbook.ActiveSheet.Copy                'erstelle aktive Kopie
'aktive Kopie zuweisen
Set oWbk = ActiveWorkbook
Set oWsh = oWbk.ActiveSheet
'keine Markenduplikate
lngSpalte = ThisWorkbook.ActiveSheet.Rows(1).Find(TITEL).Column
oWsh.Cells.RemoveDuplicates Columns:=lngSpalte, Header:=xlYes
'eindeutige Marken speichern
Arr = oWsh.Range(Cells(1, lngSpalte), Cells(1, lngSpalte).End(xlDown))
'aktive Kopie leeren
oWsh.Cells.Clear
'im Original
ThisWorkbook.Activate
'Filterfeld finden
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            'ohne Warnung
'mit filtern
ActiveSheet.UsedRange.AutoFilter
'Schleife über Datenfeld ( 0 = Überschrift)
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))                 'ggf. Leerzeichen
   strName = Replace(ThisWorkbook.FullName, _
      ThisWorkbook.Name, strName & ENDUNG)   'gleicher Pfad, neuer Name
   oWbk.SaveAs strName                       'Mappe mit Filterbegriff speichern
   oWsh.Cells.Clear                          'Kopie leeren
Next x
'filter zurück
ActiveSheet.Cells.AutoFilter
oWbk.Close savechanges:=False
Application.DisplayAlerts = True
'ferig
Application.ScreenUpdating = True
End Sub