Also dann folgt jetzt unten der Code. Der Durchläuft 8 mal eine Schleife. Je nach Durchlaufindex wird ein andere Filter gesetzt und eine andere Spalte kopiert.
Mal schnell im Durchlauf:
1. Durchlauf i = 1
Spalte A bis M Filter A oder B in M gesetzt
neues Blatt
A bis D kopiert
Spalte 7 (= G) kopiert
Name aus der eingefügten Spalte
2. Durchlauf i = 2
Spalte A bis M Filter, A oder B in M gesetzt
neues Blatt
A bis D kopiert
Spalte 8 (= H) kopiert
Name aus der eingefügten Spalte
und so weiter bis 6, wobei hier bis Spalte L kopiert wird - wird geregelt über .UsedRange.Columns(i + 6).Copy ActiveSheet.Cells(1, 5), beachte dabei Wert von i
7. Durchlauf i = 7
Spalte A bis M Filter C in M gesetzt
neues Blatt
A bis D kopiert
Spalte 11 (= K) kopiert - das wid hierüber geregelt .UsedRange.Columns(i + 4), beachte Wert von i
Name aus der eingefügten Spalte + C
8. Durchlauf i = 1
Spalte A bis M Filter C in M gesetzt
neues Blatt
A bis D kopiert
Spalte 12 (= L) kopiert
Name aus der eingefügten Spalte + C
Ende der Durchläufe
Das sollte so sein, wie du es wolltest, Geh das oben (die Durchläufe) bitte mal durch und schau, was anders werden soll.
Hier nun der Code.
Sub blatt_nach_Filter_erzeugen()
Dim i As Integer
Application.ScreenUpdating = False
'Blatt eins als Ausgang
With Worksheets(1)
' 6 für A/ B und 2 für C deshalv 8 Durchläufe kann man ändern, dann aber beim Filter darauf achten, wann C kommt
For i = 1 To 8
'Filter setzen
If i < 7 Then
'für die mit A und B
.Range("$A:$M").AutoFilter Field:=13, Criteria1:="=*A*", Operator:=xlOr, Criteria2:="=*B*"
Else
' die zwei für C ab Durchlauf 7
.Range("$A:$M").AutoFilter Field:=13, Criteria1:="=*C*"
End If
' Blatt einfügen
Worksheets.Add After:=Sheets(Sheets.Count)
'A bis D kopieren - wird gefilter kopiert - kann man aber auch wandeln, dass die 4 Spalte ungefilter eingefügt werden und dann erst der Filter kommt
.UsedRange.Range("A:D").Copy ActiveSheet.Cells(1)
' jeztt noch die Spalte je nach Index einfügen
If i < 7 Then
.UsedRange.Columns(i + 6).Copy ActiveSheet.Cells(1, 5)
Else
' wiede rbei 7 und 8
.UsedRange.Columns(i + 4).Copy ActiveSheet.Cells(1, 5)
End If
' Namen festlegen nach jew. Spalte
If i > 6 Then
ActiveSheet.Name = ActiveSheet.Cells(1, 5) + "C"
Else
ActiveSheet.Name = ActiveSheet.Cells(1, 5)
End If
Next i
'im Ausgang den Filter wieder rausnehmen
.Range("$A:$M").AutoFilter
End With
Application.ScreenUpdating = True
End Sub
|