vor einiger Zeit hat mir ein freundliches Boardmitglied beim Erstellen nachfolgender Funktion geholfen:
Sub Export3()
Dim WS
Dim i, Abt
Dim Spalte As Byte
'Hier sind auf jeden Fall Anpassungen notwendig
Spalte = 5 'in dieser Spalte ist die Abteilung
'Abteilung erfragen
Abt = InputBox("Für welche Abteilung soll eine neue Mappe erstellt werden? Bitte genaue Schreibweise beachten!")
If Abt = "" Then Exit Sub
Sheets(Array("PM", "POM", "PHM", "PHMZ")).Copy
For Each WS In ActiveWorkbook.Worksheets
'Zeilen mit falscher Abteilung Inhalt löschen
For i = WS.Cells(Rows.Count, 1).End(xlUp).Row To 13 Step -1
If WS.Cells(i, Spalte) <> Abt Then WS.Rows(i) = ""
Next i
For Each sh In WS.Shapes
sh.Delete
Next sh
Next WS
Range("A13:W212").Select
Selection.Sort Key1:=Range("L13"), Order1:=xlDescending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-6
ActiveWindow.ScrollRow = 13
Range("A13").Select
Sheets("POM").Select
Range("A13:W212").Select
Selection.Sort Key1:=Range("L13"), Order1:=xlDescending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-5
ActiveWindow.ScrollRow = 13
Range("A13").Select
Sheets("PHM").Select
Range("A13:W212").Select
Selection.Sort Key1:=Range("L13"), Order1:=xlDescending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-4
ActiveWindow.ScrollRow = 13
Range("A13").Select
Sheets("PHMZ").Select
Range("A13:W212").Select
Selection.Sort Key1:=Range("L13"), Order1:=xlDescending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-4
ActiveWindow.ScrollRow = 13
Range("A13").Select
Sheets(Array("PM", "POM", "PHM", "PHMZ")).Select
Sheets("PM").Activate
Range("A13:A212").Select
Selection.ClearContents
ActiveWindow.ScrollRow = 13
Range("A13").Select
ActiveCell.FormulaR1C1 = "1"
Range("A14").Select
ActiveCell.FormulaR1C1 = "2"
Range("A13:A14").Select
Selection.AutoFill Destination:=Range("A13:A212"), Type:=xlFillDefault
Range("A13:A212").Select
ActiveWindow.ScrollRow = 13
Range("A13").Select
Sheets("PM").Select
End Sub
Jetzt bräuchte ich diese Funktion noch einmal, jedoch soll hier nicht in einer ListBox abgefragt werden, welche Daten exportiert werden sollen. Die Funktion müsste z.B. in Spalte "Y" nachschauen, ob dort für den Mitarbeiter ein "m" (männlich) oder ein "w" (weiblich) eingetragen ist und dann eine neue Mappe mit diesen ausgewählten Mitarbeitern generieren.
Es wäre nett, wenn mir jemand dabei helfen könnte.
Im Voraus bereits vielen Dank für euere Hilfe.
mfg Klaus