Hallo

dann evtl. so???

<pre style='border:thin solid #000000; padding:12px 24px; margin-left:12px; color:#000000'><span style='color:#0000EE'>Sub</span> speicher()&#10;    <span style='color:#0000EE'>On</span> <span style='color:#0000EE'>Error</span> <span style='color:#0000EE'>GoTo</span> Fehler&#10;    &#10;    <span style='color:#0000EE'>Dim</span> wkb <span style='color:#0000EE'>As</span> Workbook, wkbNeu <span style='color:#0000EE'>As</span> Workbook, wks <span style='color:#0000EE'>As</span> Worksheet, wksTmp <span style='color:#0000EE'>As</span> Worksheet, wksNeu <span style='color:#0000EE'>As</span> Worksheet&#10;    <span style='color:#0000EE'>Dim</span> i <span style='color:#0000EE'>As</span> <span style='color:#0000EE'>Integer</span>, LR <span style='color:#0000EE'>As</span> <span style='color:#0000EE'>Integer</span>&#10;    <span style='color:#0000EE'>Dim</span> Arr()&#10;    <span style='color:#0000EE'>Dim</span> Pfad <span style='color:#0000EE'>As</span> <span style='color:#0000EE'>String</span>, Dateiname <span style='color:#0000EE'>As</span> <span style='color:#0000EE'>String</span>&#10;    &#10;    <span style='color:#0000EE'>With</span> Application&#10;        .ScreenUpdating = <span style='color:#0000EE'>False</span>&#10;        .Calculation = xlCalculationManual&#10;    <span style='color:#0000EE'>End</span> <span style='color:#0000EE'>With</span>&#10;    &#10;    <span style='color:#0000EE'>Set</span> wkb = ThisWorkbook&#10;    &#10;    <span style='color:#0000EE'>Set</span> wks = wkb.ActiveSheet&#10;    Pfad = wks.Range(<span style='color:#FF0000'>&quot;I4&quot;</span>)&#10;    Dateiname = wks.Range(<span style='color:#FF0000'>&quot;I23&quot;</span>)&#10;    &#10;    <span style='color:#0000EE'>If</span> wks.AutoFilterMode <span style='color:#0000EE'>Then</span> wks.AutoFilterMode = <span style='color:#0000EE'>False</span> <span style='color:#008000'>' Autofilter ausschalten </span>&#10;    &#10;    <span style='color:#0000EE'>Set</span> wksTmp = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))&#10;    &#10;    <span style='color:#0000EE'>With</span> wksTmp&#10;        <span style='color:#008000'>'kopieren und Duplikate raus </span>&#10;        wks.Columns(<span style='color:#DDAA00'>4</span>).Copy .Columns(<span style='color:#DDAA00'>1</span>)&#10;        .Columns(<span style='color:#DDAA00'>1</span>).RemoveDuplicates Columns:=1, Header:=xlYes&#10;        &#10;        LR = .Cells(.Rows.Count, <span style='color:#DDAA00'>1</span>).End(xlUp).Row <span style='color:#008000'>'letzte Zeile der Spalte 1 </span>&#10;    &#10;        Arr = .Range(.Cells(<span style='color:#DDAA00'>2</span>, <span style='color:#DDAA00'>1</span>), .Cells(LR, <span style='color:#DDAA00'>1</span>))&#10;    <span style='color:#0000EE'>End</span> <span style='color:#0000EE'>With</span>&#10;    &#10;    <span style='color:#008000'>'Neues Blatt erstellen und gefilterte Daten kopieren </span>&#10;    <span style='color:#0000EE'>Set</span> wkbNeu = Workbooks.Add&#10;    <span style='color:#0000EE'>For</span> i = <span style='color:#0000EE'>Lbound</span>(Arr) <span style='color:#0000EE'>To</span> <span style='color:#0000EE'>Ubound</span>(Arr)&#10;        <span style='color:#0000EE'>Set</span> wksNeu = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))&#10;        wks.Columns(<span style='color:#DDAA00'>4</span>).AutoFilter Field:=1, Criteria1:=Arr(i, <span style='color:#DDAA00'>1</span>)&#10;        wks.Columns(<span style='color:#DDAA00'>1</span>).Resize(, <span style='color:#DDAA00'>3</span>).Copy wksNeu.Columns(<span style='color:#DDAA00'>1</span>).Resize(, <span style='color:#DDAA00'>3</span>)&#10;        wksNeu.Name = Arr(i, <span style='color:#DDAA00'>1</span>)&#10;             &#10;        <span style='color:#008000'>'Blatt in neue Datei verschieben </span>&#10;        wksNeu.Move after:=wkbNeu.Sheets(wkbNeu.Sheets.Count)&#10;    <span style='color:#0000EE'>Next</span>&#10;    &#10;    <span style='color:#008000'>'Filter ausschalten </span>&#10;    wks.AutoFilterMode = <span style='color:#0000EE'>False</span>&#10;    &#10;    <span style='color:#008000'>'tempor&auml;res Blatt l&ouml;schen </span>&#10;    Application.DisplayAlerts = <span style='color:#0000EE'>False</span>&#10;    wksTmp.Delete&#10;    &#10;    <span style='color:#008000'>'Neue Datei speichern und schlie&szlig;en </span>&#10;    wkbNeu.SaveAs Filename:=Pfad & <span style='color:#FF0000'>&quot;\&quot;</span> & Dateiname & <span style='color:#FF0000'>&quot;.xlsx&quot;</span>, _&#10;        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False&#10;    wkbNeu.Close&#10;&#10;    <span style='color:#008000'>'*** Fehlerbehandlung </span>&#10;    Err.Clear&#10;    &#10;Fehler:&#10;    <span style='color:#008000'>'*** R&uuml;cksetzen </span>&#10;    <span style='color:#0000EE'>With</span> Application&#10;        .DisplayAlerts = <span style='color:#0000EE'>True</span>&#10;        .ScreenUpdating = <span style='color:#0000EE'>True</span>&#10;        .Calculation = xlCalculationAutomatic&#10;    <span style='color:#0000EE'>End</span> <span style='color:#0000EE'>With</span>&#10;    <span style='color:#0000EE'>If</span> Err.Number &lt;&gt; <span style='color:#DDAA00'>0</span> <span style='color:#0000EE'>Then</span> MsgBox <span style='color:#FF0000'>&quot;Fehler&#58; &quot;</span> & _&#10;        Err.Number & vbLf & Err.Description: Err.Clear&#10;<span style='color:#0000EE'>End</span> <span style='color:#0000EE'>Sub</span></pre>

LG UweD