Filtern / in neue Datei kopieren

Sub xxx() Dim Jahr As Long Dim wb As Workbook Dim shQ As Worksheet Dim shZ As Worksheet Set shQ = ActiveSheet Set wb = Workbooks.Add(xlWBATWorksheet) Set shZ = wb.Sheets(1) For Jahr = 2015 To 2025 'alle jahre, die theoretisch in Frage kommen If WorksheetFunction.CountIf(sh.Columns(1), "*" & Jahr & "*") > 0 Then '--- alles als Wert mit Format übertragen shQ.UsedRange.Copy shZ.Cells(1, 1).PasteSpecial xlPasteValues shZ.Cells(1, 1).Pastespeical xlPasteFormats shZ.Cells(1, 1).PasteSpecial xlPasteColumnWidths '--- nicht benötigte Zeilen löschen With shZ.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(Countif(RC1,""*""&Jahr&""*""),Row(),0)" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With '--- nicht benötigte Spalten löschen shZ.Range("B1,D1,F1:I1,Z1").EntireColumn.Delete '--- speichern wb.SaveAs ThisWorkbook.Path & "\xxx_" & Jahr, FileFormat:=xlOpenXMLWorkbook End If Next wb.Close False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Mat,
verwende dafür den Power Query:
_ positioniere dein Zeiger auf eine der Zelle der zu behandelnde Liste
_ gehe auf Menü "Daten", "Aus Tabelle",
_ es wird die Gesamtheit der Tabelle erkannt. Hat Überschrift: ja.
_ dann bist Du in Power Query Editor
_ Rechtklick auf der Überschirft vom 5te Spalte, "Entfernen".
_ filtere die Spalte Jahr mit enthält "2019"
_ Menü "Datei", "Schliessen und laden"
_ auf dem Reiter des neuen Blattes, Rechtklick und "Verschieben oder Kopieren...", kopieren in einer neuen Mappe.
_ Mappe speichern und schliessen
_ auf der Abfrage, Rechtklick und "Bearbeiten"
_ in den Schritte auf das Zahnrädchen von Filter gehen
_ den "2019" in "2020" ändern
_ "Schliessen & laden"
_ usw...
VG
Yal

Hallo Yal,
danke für Dein Feedback - aber ich muss das i.d.R. zwei mal pro Woche machen. und bei ca. 20 bis 30 Jahren (=einzelnen Dateien) ist das manuell ziemlich aufwendig. Daher die Hoffnung, das per Makro zu machen.
In dem Code habe ich ein paar Typos gefunden - das Makro läuft jetzt durch und kopiert alle Werte aus der Quell-Datei in je eine neue.


Sub copy_()
Dim Jahr As Long
Dim wb As Workbook
Dim shQ As Worksheet
Dim shZ As Worksheet
Set shQ = ActiveSheet
Set wb = Workbooks.Add(xlWBATWorksheet)
Set shZ = wb.Sheets(1)
For Jahr = 2015 To 2025 'alle jahre, die theoretisch in Frage kommen
If WorksheetFunction.CountIf(shQ.Columns(1), "*" & Jahr & "*") > 0 Then
'--- alles als Wert mit Format übertragen
shQ.UsedRange.copy
shZ.Cells(1, 1).PasteSpecial xlPasteValues
shZ.Cells(1, 1).PasteSpecial xlPasteFormats
shZ.Cells(1, 1).PasteSpecial xlPasteColumnWidths
'--- nicht benötigte Zeilen löschen
With shZ.UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=IF(Countif(RC1,""*""&Jahr&""*""),Row(),0)"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With
'--- nicht benötigte Spalten löschen
shZ.Range("B1").EntireColumn.Delete
'--- speichern
wb.SaveAs ThisWorkbook.Path & "\xxx_" & Jahr, FileFormat:=xlOpenXMLWorkbook
End If
Next
wb.Close False
End Sub

Auch werden wie erwartet die nicht benötigten spalten gelöscht...


'--- nicht benötigte Spalten löschen
shZ.Range("B1").EntireColumn.Delete

Was richtig blöd ist, dass dieser Teil alle Zeilen abgesehen von der Überschrift löscht. Im Ergebnis habe ich also lauter leere Dateien mit dem "richtigen" Dateinamen.


'--- nicht benötigte Zeilen löschen
With shZ.UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=IF(Countif(RC1,""*""&Jahr&""*""),Row(),0)"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With

Wie muss ich das Makro umschreiben, damit ggf. einfach "nur" alle Zeilen mit der entsprechenden Jahreszahl in der Filterspalte kopiert werden?

Application.DisplayAlerts = False 'Sonst verlangt DataBodyRange. .. .Delete eine Bestätigung With Tabelle1.ListObjects("Tabelle1") .Range.AutoFilter Field:=3, Criteria1:="*2019*", Operator:=xlAnd .DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Delete .Range.AutoFilter Field:=3 'Filter-Reset End With Application.DisplayAlerts = True

Sub copy_() Dim Jahr As Long Dim wb As Workbook Dim shQ As Worksheet Dim shZ As Worksheet Set shQ = ActiveSheet Set wb = Workbooks.Add(xlWBATWorksheet) Set shZ = wb.Sheets(1) For Jahr = 2015 To 2025 'alle jahre, die theoretisch in Frage kommen If WorksheetFunction.CountIf(shQ.Columns(1), "*" & Jahr & "*") > 0 Then '--- alles als Wert mit Format übertragen shQ.UsedRange.copy shZ.Cells(1, 1).PasteSpecial xlPasteValues shZ.Cells(1, 1).PasteSpecial xlPasteFormats shZ.Cells(1, 1).PasteSpecial xlPasteColumnWidths '--- nicht benötigte Zeilen löschen Application.DisplayAlerts = False 'Sonst verlangt DataBodyRange. .. .Delete eine Bestätigung With Sheets("Sheet1") With .ListObjects.Add(xlSrcRange, .Cells(1, 2).CurrentRegion, , xlYes) .Name = "Table1" ' .ShowTotals = True .Range.AutoFilter Field:=1, Criteria1:="*" & Jahr & "*", Operator:=xlAnd .DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Delete .Range.AutoFilter Field:=1 'Filter-Reset End With End With Application.DisplayAlerts = True '--- nicht benötigte Spalten löschen shZ.Range("B:B").Delete Shift:=xlToLeft '--- speichern wb.SaveAs ThisWorkbook.Path & "\xxx_" & Jahr, FileFormat:=xlOpenXMLWorkbook End If Next wb.Close False End Sub

Sub copy_() Dim Jahr As Long Dim wbZ As Workbook Dim ws As Worksheet Const cAbfrage = "so_hiesst_meine_Abfrage" 'Anpassen For Jahr = 2015 To 2025 'alle jahre, die theoretisch in Frage kommen 'Neues Blatt herstellen Sheets.Add After:=ActiveSheet Set ws = ActiveSheet 'Abfrage in das Blatt herausgeben With ws.ListObjects.Add(SourceType:=0, _ Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & cAbfrage & ";Extended Properties=""""", Destination:=Range("$A$1")).QueryTable .CommandType = xlCmdSql .CommandText = Array("SELECT * FROM [" & cAbfrage & "] Where [Jahr] = " & Jahr) 'Achtung: ev. Spaltename anpassen .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells 'Aktualisieren .Refresh BackgroundQuery:=False End With 'Link zu Abfrage lösen ws.ListObjects(1).Unlink 'Blatt in einer neue Arbeitsmappe versetzen ws.Move Set wbZ = ws.Parent 'Speichern unter Name+Jahr und schliessen wbZ.SaveAs ThisWorkbook.Path & "\xxx_" & Jahr, FileFormat:=xlOpenXMLWorkbook wbZ.Close Next End Sub

Sub xxx() Dim Jahr As Long Dim wb As Workbook Dim shQ As Worksheet Dim shZ As Worksheet Set shQ = ActiveSheet Set wb = Workbooks.Add(xlWBATWorksheet) Set shZ = wb.Sheets(1) For Jahr = 2015 To 2025 'alle jahre, die theoretisch in Frage kommen If WorksheetFunction.CountIf(shQ.Columns(1), "*" & Jahr & "*") > 0 Then '--- alles als Wert mit Format übertragen shQ.UsedRange.Copy shZ.Cells(1, 1).PasteSpecial xlPasteValues shZ.Cells(1, 1).Pastespeical xlPasteFormats shZ.Cells(1, 1).PasteSpecial xlPasteColumnWidths '--- nicht benötigte Zeilen löschen With shZ.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(Countif(RC1,""*""&Jahr&""*""),Row(),0)" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With '--- nicht benötigte Spalten löschen shZ.Range("B1,D1,F1:I1,Z1").EntireColumn.Delete '--- speichern wb.SaveAs ThisWorkbook.Path & "\xxx_" & Jahr, FileFormat:=xlOpenXMLWorkbook End If Next wb.Close False End Sub

With shZ.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(Countif(RC1,""*""&Jahr&""*""),Row(),0)" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Filtern / in neue Datei kopieren

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread