Daten Spalte C nach Monat in neue Tabellenblätter aufteilen - Spezialfilter...

Frage: Alle Buchungen aus dem Jahre 2013 befinden sich auf einem Tabellenblatt. Das Datum steht in Spalte C. Die Daten müssen in neue Tabellenblätter aufgeteilt werden. Die Daten müssen nach Monat kopiert werden. Wie geht das?

All bookings from the year 2013 are on a worksheet. The date is in column C. The data must be divided into new worksheets. The data must be copied by month. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Daten Spalte C nach Monat in neue Tabellenblätter aufteilen - Spezialfilter...[XLS 250 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 21.01.2014
' Purpose   : Daten Spalte C Datum - Monat in Tabellenblätter aufteilen...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim CriteriaSheet As Worksheet
    Dim SourceSheet As Worksheet
    Dim rngCriterion As Range
    Dim wksNew As Worksheet
    Dim wksTMP As Worksheet
    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
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Schleife über jeder Tabellenblatt in dieser Datei
    For Each wksTMP In ThisWorkbook.Worksheets
        ' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
        If wksTMP.Index > 1 Then
            ' ... lösche es
            wksTMP.Delete
        End If
    Next wksTMP
    ' Tabellenblatt mit den Grunddaten - Name ANPASSEN
    Set SourceSheet = Worksheets("2013")
    ' Ein Kriterientabellenblatt wird hinzugefügt
    Set CriteriaSheet = Worksheets.Add
    ' Und an das Ende verschoben
    CriteriaSheet.Move After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ' Ermittelt die letzte belegte Zeile im Quelltabellenblatt Splate C
    lngLastRow = SourceSheet.Range("C" & Rows.Count).End(xlUp).Row
    ' Füge eine Hilfsspalte im Quelltabellenblatt vor Spalte A ein
    SourceSheet.Range("A1").EntireColumn.Insert
    ' Setzt eine Überschrift
    SourceSheet.Range("A1").Value = "TEMP"
    ' Per Formel die Monatszahl in jede Zelle schreiben
    SourceSheet.Range("A2:A" & lngLastRow).Formula = "=Month(D2)"
    ' Dann die Kriterien ohne Doppelte ins Lriterientabellenblatt kopieren
    SourceSheet.Range("A1:A" & lngLastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=CriteriaSheet.Range("A1"), Unique:=True
    ' Das erste Kriterium zuweisen
    Set rngCriterion = CriteriaSheet.Range("A2")
    ' So lange schleifen, bis kein Kriterium mehr vorhanden ist
    While rngCriterion.Value <> ""
        ' Neues Tabellenblatt
        Set wksNew = Worksheets.Add
        ' Ans Ende stellen
        wksNew.Move After:= _
            ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ' Über Spezialfilter den jeweiligen Monat kopieren
        SourceSheet.Range("A1:H" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngCriterion.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1")
        ' Tabellenblatt mit Monatsnamen benennen
        wksNew.Name = Format(wksNew.Range("D2").Value, "MMMM")
        ' Die temporäre erste Spalte löschen
        wksNew.Columns("A").Delete
        ' Das erledigte Kriterium löschen
        rngCriterion.EntireRow.Delete
        ' Setze die Objektvariablen auf Nothing
        Set rngCriterion = Nothing
        Set wksNew = Nothing
        ' Das nächste Kriterium zuweisen
        Set rngCriterion = CriteriaSheet.Range("A2")
    Wend
    ' Die temporäre Spalte auch im Quelltabellenblatt löschen
    SourceSheet.Columns("A").Delete
    ' Wenn ein Kriterientabellenblatt vorhanden ist, lösche es
    If Not CriteriaSheet Is Nothing Then CriteriaSheet.Delete
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Gehe zum Quelltabellenblatt nach A1
        .Goto SourceSheet.Range("A1"), True
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set CriteriaSheet = Nothing
    Set SourceSheet = Nothing
    Set rngCriterion = Nothing
    Set wksNew = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...