Option Explicit
Sub X()
Application.ScreenUpdating = False
Dim LastRow&, Krit%
Dim rng As Range, rng2 As Range, shTMD As Object, newSh As Object
Set shTMD = Sheets("Total (Monthly Development)")
'Hier wird der Autfilter gesetzt
With shTMD
LastRow = .Range("C3000").End(xlUp).Row 'letzte Zelle in Spalte C über Zeile 3000
.AutoFilterMode = False
Set rng = .Range(.Cells(3, 1), .Cells(LastRow, 8)) 'gefilterter Bereich
Set rng2 = .UsedRange 'benutzter Bereich im Tabellenblatt
End With
rng.AutoFilter
'Hier werden die sheets kopiert und nach dem criterium benannt. Da es nur sechs sind, habe ich die einzelnen Vorgänge mehrmals eingetippt. Geht bestimmt auch einfacher.
For Krit = 6 To 1 Step -1
delSheet CStr(Krit)
Set newSh = Sheets.Add(, shTMD)
With newSh
.Name = Krit
rng2.Copy Destination:=.Range(rng2.Address)
With .Range(rng.Address)
.AutoFilter
.AutoFilter Field:=6, Criteria1:=Krit
.AutoFilter Field:=rng.Columns.Count - 1, Criteria1:="Actual"
End With
End With
Next
Application.ScreenUpdating = True
End Sub
Private Sub delSheet(sh)
Application.DisplayAlerts = 0
On Error Resume Next
Sheets(sh).Delete
Application.DisplayAlerts = 1
End Sub
Ja, das war Absicht, dass das unformatiert ist... kannst du ziemlich leicht mit Copy und PasteSpecial anpassen, oder mit Copy Destination, alles außer Shapes (s.o) kopieren...
|