PDA

Vollständige Version anzeigen : Macro verfeinern!


Metaplois
26.01.2009, 18:38
Hallo, ich habe ein Macro. Dieser greift in einer Spalte, sortiert danach und kopiert die Daten in einem neuen Fenster. Jetzt gibt es mehrere Einträge nach denen ich sortieren kann. Mein Macro sortiert ausschließlich nach einem Eintrag und kopiert dann die Daten in ein neues Fenster. Meine Frage: Wie kann das Macro so abgeändert werden, dass es für jeden Eintrag in der Auswahlliste die Daten sortiert und diese in einer neuen Datei, mit dem Namen aus der Auswahlliste einschliesslich Datum und uhrzeit, schreibt. Das mit dem Datum und der Uhrzeit und in einem Unterordner klappt schon. Hier das Macro:

Sub CopyNew()
' Macro recorded 01/01/2009 by M
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Tabelle1").Select
' Hier ist die Auswahl
Selection.AutoFilter Field:=16, Criteria1:="Donald"
Cells.Select
Selection.Copy
Workbooks.Add
Sheets("Mappe1").Select
ActiveSheet.Paste
Sheets("Mappe1").Name = "Tabelle2"

Columns("B:B").Select
Selection.ColumnWidth = 35
Columns("J:J").ColumnWidth = 45
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Range("B2").Select

On Error Resume Next
Application.DisplayAlerts = False
Sheets("Base_C").Select
Rows("1:1").Select
Selection.AutoFilter

ActiveWindow.SplitRow = 0.92156862745098
ActiveWindow.SplitColumn = 1.98882681564246
ActiveWindow.FreezePanes = True
ActiveWindow.SmallScroll Down:=-6
Range("B2").Select
ActiveWindow.SmallScroll Down:=-6

WB = ThisWorkbook.Path
DatFolder = WB & "\Unterordner\"
ActiveWorkbook.SaveAs Filename:= _
DatFolder & Format(Now, "dd.mm.yyyy hh-mm-ss") & _
IIf(Range("B31") = "0" And Range("B33") = "0", "", _
IIf(Range("B31") <> "" And Range("B33") = "0", " C", _
IIf(Range("B31") = "0" And Range("B33") <> "", " B", ""))) _
& ".xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False

'DatFolder = WB & "\Unterordner\"
'ActiveWorkbook.SaveAs Filename:= _
'DatFolder & Format(Now, "dd.mm.yyyy hh-mm-ss") & ".xls", FileFormat _
':=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
'False, CreateBackup:=False

ActiveWindow.Close
Selection.AutoFilter Field:=16
ActiveWindow.LargeScroll ToRight:=-1
Range("A1").Select
End Sub

Metaplois
27.01.2009, 18:36
Ich habe das noch mal verkleinert:
Sub Other_B()
' Macro recorded 2/9/2006 by M.
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Base_B").Select
Selection.Autofilter Field:=1, Criteria1:="="
Cells.Select
Selection.Copy
Sheets("Other_B").Select
Range("A2").Select
ActiveSheet.Paste
Range("A3").Select
End Sub

Es geht um das Criterium. Es soll für jedes Criterium im Feld 1 eine neues Sheet erstellen und die Daten die vorher kopiert wurden rein kopieren.