AW: Daten auf mehrere Blätter verteilen
23.06.2014 09:56:41
UweD
Hallo
so?
Sub Filter_copieren()
On Error GoTo Fehler
Dim TB1, TB2, TB3
Dim SP%, ZE&, LR&, i%, j%, FI$
Dim stCalc%
'*** bescheunigt das Makro
With Application
.ScreenUpdating = False
stCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set TB1 = Sheets("Alle")
SP = 10 'Spalte J mit Kreditor
ZE = 2 'ab Zeile
Sheets.Add After:=Sheets(Sheets.Count)
Set TB2 = ActiveSheet 'Temp
With TB1
If .FilterMode Then .ShowAllData ' Autofilter alle
.Columns(SP).Copy TB2.Cells(1, SP)
TB2.Columns(SP).RemoveDuplicates Columns:=1, Header:=xlYes
LR = TB2.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For i = ZE To LR
FI = TB2.Cells(i, SP)
Application.DisplayAlerts = False
Sheets(FI).Delete 'Blatt löschen, wenn schon da
Application.DisplayAlerts = True
Sheets.Add After:=Sheets(Sheets.Count)
Set TB3 = ActiveSheet
TB3.Name = FI
.Range("$A:$AJ").AutoFilter Field:=SP, Criteria1:=FI
.UsedRange.Copy TB3.Cells(1, 1)
'TB3.Cells(1, 1).Select 'evtl.
Next
Application.DisplayAlerts = False
TB2.Delete
Application.DisplayAlerts = True
.ShowAllData
End With
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
'*** Rücksetzen
With Application
.ScreenUpdating = True
.DisplayAlerts = True
If .Calculation stCalc Then .Calculation = stCalc
End With
End Sub
Gruß UweD