Daten auf mehrere Blätter verteilen

schütti · 2014-06-23T08:59:05+00:00

Hallo, ich möchte eine Datentabelle mit 15.000 Zeilen und Spalten von A-AJ für alle in Spalte J vorkommenden Werte (Kreditornummern) filtern, das jeweilige Ergebnis auf ein neu einzufügendes Tabellenblatt kopieren, das Tabellenblatt mit der Kreditornummer benennen. Die Daten auf dem ersten Blatt müssen nicht gelöscht werden. Könnt ihr mir hier bitte bei helfen? Lieben Dank im Voraus. Viele Grüße, schütti

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

Hi
probier mal das.
Die Daten werden sortiert, daher sollte es etwas schneller gehen als mit Autofilter
Zeile 1 ist überschrift und wird mit kopiert.

Sub Aufteilen()
Dim Zelle1 As Range
Dim Zelle2 As Range
Dim shQuelle As Worksheet
Set shQuelle = ActiveSheet
With shQuelle.UsedRange
.Sort key1:=.Cells(1, 10), order1:=xlAscending, Header:=xlYes
Set Zelle1 = .Cells(2, 10)
Do Until Zelle1 = ""
Set Zelle2 = Zelle1.EntireColumn.Find(what:=Zelle1.Value, lookat:=xlWhole,  _
searchdirection:=xlPrevious)
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Zelle1.Value
.Rows(1).Copy ActiveSheet.Cells(1, 1)
Range(Zelle1, Zelle2).EntireRow.Copy ActiveSheet.Cells(2, 1)
Set Zelle1 = Zelle2.Offset(1, 0)
Loop
End With
End Sub

Gruß Daniel

Kreditornummer	Name
123	Max
456	Anna
123	Tom

Daten auf mehrere Blätter verteilen

Forumthread: Daten auf mehrere Blätter verteilen

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial