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
Keine Kommentare:
Kommentar veröffentlichen