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 Tabelleblattname. 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
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
OptionExplicit
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 11.12.2013
' Purpose : Daten Spalte B jeweils in neue Dateien aufteilen - Summe...
'--------------------------------------------------------------------------
SubMain()
' Variablendeklaration
DimwksKriterienSheetAsWorksheet
DimwksQuellSheetAsWorksheet
DimrngKriteriumAsRange
DimwksNewAsWorksheet
DimwkbBookAsWorkbook
DimlngLastTMPAsLong
DimlngLastRowAsLong
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
.ScreenUpdating=False
.EnableEvents=False
.DisplayAlerts=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Tabellenblatt mit Daten - Name ANPASSEN!!!
SetwksQuellSheet=Worksheets("Total")
' Neues Tabellenblatt für die Kriterien
' Man könnte es auch ohne dieses zusätzliche Sheet machen
SetwksKriterienSheet=Worksheets.Add
' Tabellenblatt verschieben - muss man nicht - kann man :-)
wksKriterienSheet.MoveAfter:=_
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
' Letzte Zeile der Spalte B im Quellsheet ermitteln
WithwksQuellSheet
lngLastRow=IIf(IsEmpty(.Cells(.Rows.Count,1)),_
.Cells(.Rows.Count,1).End(xlUp).Row,.Rows.Count)
EndWith
' 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
SetrngKriterium=wksKriterienSheet.Range("A2")
' Schleife bis alle Kriterien abgearbeitet sind
WhilerngKriterium.Value<>""
' Temporäres Tabellenblatt - nimmt die Daten auf
SetwksNew=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
SetwkbBook=ActiveWorkbook
' Summen- und Berechnungsformel eintragen
WithwkbBook.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
EndWith
' Wenn die Applikation < Excel 2007 ist dann...
IfVal(Application.Version)<12Then
wkbBook.SaveAsThisWorkbook.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.SaveAsThisWorkbook.Path&_
Application.PathSeparator&"Number_"&wksNew.Name,56
EndIf
' Datei schliessen ohne zu speichern
wkbBook.CloseSaveChanges:=False
' Setze die Objektvariable auf Nothing
SetwkbBook=Nothing
' Temporäres Tabellenblatt löschen
wksNew.Delete
' Setze die Objektvariablen auf Nothing
SetwksNew=Nothing
SetrngKriterium=Nothing
' Das nächste Kriterium
SetrngKriterium=wksKriterienSheet.Range("A2")
' Schleife
Wend
' Kriteriumstabellenblatt löschen
wksKriterienSheet.Delete
' Setze die Objektvariable auf Nothing
SetwksKriterienSheet=Nothing
Fin:
' Bei Bedarf temporäre Tabellenblätter/Datei löschen/schliessen
IfNotwkbBookIsNothingThenwkbBook.CloseSaveChanges:=False
IfNotwksNewIsNothingThenwksNew.Delete
IfNotwksKriterienSheetIsNothingThenwksKriterienSheet.Delete
' Setze die Objektvariablen auf Nothing
SetwkbBook=Nothing
SetwksKriterienSheet=Nothing
SetwksQuellSheet=Nothing
SetrngKriterium=Nothing
SetwksNew=Nothing
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.EnableEvents=True
.DisplayAlerts=True
.Calculation=lngCalc
.DisplayAlerts=True
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub