AW: fast fertig! Nur Datumsangabe fehlt noch
03.04.2014 13:05:34
Susann
Hallo und vielen Dank für die Antwort,
auch durch Deine Hilfe konnte ich mir nun das Makro zusammenbasteln und es scheint auch sehr gut zu funktionieren (Makro nachstehend, sorry, dass es so lang ist).
Das einzige was mir hier noch fehlt, ist dass es beim abspeichrn der Datei das aktuelle Datum in den Dateinamen mit einfügt, so dass die Datei dann heißt: Verträge Göttingen_03.04.2014.xlsx (oder so ähnlich):
Workbooks.Add
ActiveWorkbook.SaveAs "D:\Documents and Settings\suf.....\Verträge Göttingen.xlsx"
Und in wieweit muss dann der nachstehende Makro-Part geändert werden, wenn die Datei mit aktuellem Datum versehen wieder geöffnet werden soll?
Workbooks.Open "D:\Documents and Settings\suf.....\Verträge Göttingen.xlsx"
Range("A1").Select
Hier das aktuell funktionierende Makro_nur ohne dass die neuen Mappen mit aktuellem Datum abspeichert:
Sub gefilterte_Daten_in_neue_Mappen_kopieren()
'** Autofilter für Verträge Göttingen mit mehreren Kriterien
'** in Spalte B setzen
'** Dimensionierung der Variablen
Dim rngFilterRange As Range
Dim lngCriteriaCount As Long
Dim arrCriteria() As String
'** Anzahl der Kriterien festlegen
lngCriteriaCount = 3
'** Variable neu dimensionieren
ReDim arrCriteria(0 To lngCriteriaCount - 1)
'** Filterkriterien festlegen
arrCriteria(0) = "195022"
arrCriteria(1) = "2507658"
arrCriteria(2) = "4869444"
'** Objektvariable setzen
Set rngFilterRange = ActiveSheet.Range("A1:GH200000")
'** Autofilter setzen/ausführen
rngFilterRange.AutoFilter Field:=2, _
Criteria1:=arrCriteria(), _
Operator:=xlFilterValues
'** Objektvariable zurücksetzen
Set rngFilterRange = Nothing
Workbooks.Add
ActiveWorkbook.SaveAs "D:\Documents and Settings\suf.....\Verträge Göttingen.xlsx"
ActiveWorkbook.Close
Sheets("Tabelle1").Select
Dim loLetzte As Long
loLetzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
Range("A1:GH" & loLetzte).copy
Workbooks.Open "D:\Documents and Settings\suf.....\Verträge Göttingen.xlsx"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Close True
Application.CutCopyMode = False
'** Autofilter zurücksetzen, dieses Makro wurde aufgezeichnet
ActiveSheet.Rows("1:1").Select
Selection.AutoFilter
'** Autofilter für Verträge Einbeck mit mehreren Kriterien
'** in Spalte B setzen
'** Dimensionierung der Variablen
Dim rngFilterRange As Range
Dim lngCriteriaCount As Long
Dim arrCriteria() As String
'** Anzahl der Kriterien festlegen
lngCriteriaCount = 2
'** Variable neu dimensionieren
ReDim arrCriteria(0 To lngCriteriaCount - 1)
'** Filterkriterien festlegen
arrCriteria(0) = "2505648"
arrCriteria(1) = "4865420"
'** Objektvariable setzen
Set rngFilterRange = ActiveSheet.Range("A1:GH200000")
'** Autofilter setzen/ausführen
rngFilterRange.AutoFilter Field:=2, _
Criteria1:=arrCriteria(), _
Operator:=xlFilterValues
'** Objektvariable zurücksetzen
Set rngFilterRange = Nothing
Workbooks.Add
ActiveWorkbook.SaveAs "D:\Documents and Settings\suf.....\Verträge Einbeck.xlsx"
ActiveWorkbook.Close
Sheets("Tabelle1").Select
Dim loLetzte As Long
loLetzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
Range("A1:GH" & loLetzte).copy
Workbooks.Open "D:\Documents and Settings\suf.....\Verträge Einbeck.xlsx"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Close True
Application.CutCopyMode = False
'** Autofilter zurücksetzen, dieses Makro wurde aufgezeichnet
ActiveSheet.Rows("1:1").Select
Selection.AutoFilter
'Analog dazu werden dann gleiche bzw. ähnliche makros hier angefügt denn iese Vorgänge _
wiederholen sich dann immer wieder, bis für alle Suchkriterien alle neue bfüllten Excel-Datein erstellt worden sind
End Sub
Beste Grüße, Susann