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]
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]
OptionExplicit
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 21.01.2014
' Purpose : Daten Spalte C Datum - Monat in Tabellenblätter aufteilen...
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimCriteriaSheetAsWorksheet
DimSourceSheetAsWorksheet
DimrngCriterionAsRange
DimwksNewAsWorksheet
DimwksTMPAsWorksheet
DimlngLastRowAsLong
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' 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
EndWith
' Schleife über jeder Tabellenblatt in dieser Datei
ForEachwksTMPInThisWorkbook.Worksheets
' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
IfwksTMP.Index>1Then
' ... lösche es
wksTMP.Delete
EndIf
NextwksTMP
' Tabellenblatt mit den Grunddaten - Name ANPASSEN
SetSourceSheet=Worksheets("2013")
' Ein Kriterientabellenblatt wird hinzugefügt
SetCriteriaSheet=Worksheets.Add
' Und an das Ende verschoben
CriteriaSheet.MoveAfter:=_
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
SetrngCriterion=CriteriaSheet.Range("A2")
' So lange schleifen, bis kein Kriterium mehr vorhanden ist
WhilerngCriterion.Value<>""
' Neues Tabellenblatt
SetwksNew=Worksheets.Add
' Ans Ende stellen
wksNew.MoveAfter:=_
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
SetrngCriterion=Nothing
SetwksNew=Nothing
' Das nächste Kriterium zuweisen
SetrngCriterion=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
IfNotCriteriaSheetIsNothingThenCriteriaSheet.Delete
Fin:
' Die Applikation aufwecken
WithApplication
' Gehe zum Quelltabellenblatt nach A1
.GotoSourceSheet.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
EndWith
' Setze die Objektvariablen auf Nothing
SetCriteriaSheet=Nothing
SetSourceSheet=Nothing
SetrngCriterion=Nothing
SetwksNew=Nothing
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub