Hallo zusammen,

ich habe einen Code gefunden, welcher prinzipiell das tut, was er soll. Allerdings benötige ich den Dateinamen mit anderen Werten. In dem Fall existiert eine große Masterdatei, mit ca. 200 Spalten. Der Code kopiert anhand einer Nummer in Spalte "BG" alle zugehörigen Einträge der Nummer in jeweils eine neue Excel-Datei. Im Dateinamen wird unter anderem die Nummer ausgegeben. Zudem benötige ich nun im Dateinamen auch noch den jeweiligen Wert von "BH" und "BI" (der aber natürlich nicht immer der gleiche ist). Aktuell ist der Dateiname "Nummer aus "BG" + immer der gleiche Name aus "BH". 

Option Explicit
Sub Main()
    ' Variablendeklaration
    Dim wksKriterienSheet As Worksheet
    Dim wksQuellSheet As Worksheet
    Dim rngKriterium As Range
    Dim wksNew As Worksheet
    Dim wkbBook As Workbook
    Dim lngLastTMP As Long
    Dim lngLastRow As Long
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Tabellenblatt mit Daten - Name ANPASSEN!!!
    Set wksQuellSheet = Worksheets("Detail")
    ' Neues Tabellenblatt für die Kriterien
    ' Man könnte es auch ohne dieses zusätzliche Sheet machen
    Set wksKriterienSheet = Worksheets.Add
    ' Tabellenblatt verschieben - muss man nicht - kann man :-)
    wksKriterienSheet.Move After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ' Letzte Zeile der Spalte B im Quellsheet ermitteln
    With wksQuellSheet
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
    End With
    ' Spezialfilter - Spalte B ohne Doppelte ins neue Tabellenblatt
    wksQuellSheet.Range("BG1:BG" & lngLastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
    ' Erstes Kriterium nehmen
    Set rngKriterium = wksKriterienSheet.Range("A2")
    ' Schleife bis alle Kriterien abgearbeitet sind
    While rngKriterium.Value <> ""
        ' Temporäres Tabellenblatt - nimmt die Daten auf
        Set wksNew = Worksheets.Add
        ' Spezialfilter nach Kriterium in neues Tabellenblatt
        wksQuellSheet.Range("A1:FK" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1"), Unique:=True
        ' Tabellenblatt umbenennen nach Kriterium
            wksNew.Name = rngKriterium.Text & "_" & "_" & wksQuellSheet.Cells(2, 60)
        ' Erledigtes Kriterium löschen
        rngKriterium.EntireRow.Delete
        ' Fertiges Tabellenblatt in neue Datei kopieren
        wksNew.Copy
        Set wkbBook = ActiveWorkbook
        ' Wenn die Applikation < Excel 2007 ist dann...
        If Val(Application.Version) < 12 Then
            wkbBook.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & wksNew.Name & ".xls"
        ' Sonst muss das FileFormat angegeben werden!!!
        ' Siehe folgenden Blogeintrag
        ' http://vbanet.blogspot.de/2012/07/datei-speichern-dialog-format.html
        Else
            wkbBook.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & wksNew.Name, 56
        End If
        ' Datei schliessen ohne zu speichern
        wkbBook.Close SaveChanges:=False
        ' Setze die Objektvariable auf Nothing
        Set wkbBook = Nothing
        ' Temporäres Tabellenblatt löschen
        wksNew.Delete
        ' Setze die Objektvariablen auf Nothing
        Set wksNew = Nothing
        Set rngKriterium = Nothing
        ' Das nächste Kriterium
        Set rngKriterium = wksKriterienSheet.Range("A2")
    ' Schleife
    Wend
    ' Kriteriumstabellenblatt löschen
    wksKriterienSheet.Delete
    ' Setze die Objektvariable auf Nothing
    Set wksKriterienSheet = Nothing
Fin:
    ' Bei Bedarf temporäre Tabellenblätter/Datei löschen/schliessen
    If Not wkbBook Is Nothing Then wkbBook.Close SaveChanges:=False
    If Not wksNew Is Nothing Then wksNew.Delete
    If Not wksKriterienSheet Is Nothing Then wksKriterienSheet.Delete
    ' Setze die Objektvariablen auf Nothing
    Set wkbBook = Nothing
    Set wksKriterienSheet = Nothing
    Set wksQuellSheet = Nothing
    Set rngKriterium = Nothing
    Set wksNew = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub