Daten nach Spalte B in neue Dateien aufteilen - Spezialfilter...

Frage: Daten sind in Spalte B. Alle unterschiedlichen Einträge sollen als separate Datei gespeichert werden. Die Daten sind in den Spalten A bis E und es gibt eine Überschrift. Diese soll auch in alle Dateien. Zusätzlich sollen noch Summen ausgerechnet werden. Der Name der Datei ist "irgendeinText" plus den Tabellenblattnamen. Wie geht das?

Data are in column B. All the different entries are to be stored as a separate file. The data is in columns A to E and there is a headline. This is also in all the files. In addition, still sums to be calculated. The name of the file is "some text" plus the worksheet name. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Daten nach Spalte B in neue Dateien aufteilen - Spezialfilter...[XLS 50 KB]

Link für FileFormat / Link for FileFormat:
FileFormat

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 11.12.2013
' Purpose   : Daten Spalte B jeweils in neue Dateien aufteilen - Summe...
'--------------------------------------------------------------------------
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("Total")
    ' 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("B1:B" & 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:E" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1"), Unique:=True
        ' Tabellenblatt umbenennen nach Kriterium
        wksNew.Name = rngKriterium.Text
        ' Erledigtes Kriterium löschen
        rngKriterium.EntireRow.Delete
        ' Fertiges Tabellenblatt in neue Datei kopieren
        wksNew.Copy
        Set wkbBook = ActiveWorkbook
        ' Summen- und Berechnungsformel eintragen
        With wkbBook.Worksheets(1)
            lngLastTMP = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            .Cells(lngLastTMP + 1, 3).Formula = "=Sum(C2:C" & lngLastTMP & ")"
            .Cells(lngLastTMP + 1, 5).Formula = "=Sum(E2:E" & lngLastTMP & ")"
            .Cells(lngLastTMP + 2, 5).Formula = "=(C" & lngLastTMP + 1 & _
                "-E" & lngLastTMP + 1 & ")*3"
            ' Bei Minusbeträgen wird es rot - Tausenderpunk setzen
            .Cells(lngLastTMP + 2, 5).NumberFormat = "#,##0.00;[Red]#,##0.00"
            ' Optimale Breite der Spalten
            .Columns("A:E").AutoFit
        End With
        ' Wenn die Applikation < Excel 2007 ist dann...
        If Val(Application.Version) < 12 Then
            wkbBook.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & "Number_" & 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 & "Number_" & 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