besser kann ichs nicht !
ransi
hallo helmut
habe diesen code (optimierte version von eben) in deiner auf 20000 datensätze erweiterten beispieltabelle durchlaufen lassen.
Die tabelle hat 20000 datensätze mit zahlen in spalte H im bereich von 1000-9999 und in den anderen zellen buchstaben und ist aufsteigend sortiert.
der code erstellt die blätter und schafft die aufteilung der daten in die verschiedenen blätter in etwas über 2 minuten ohne fehler.
(pentium III mit 128 MB arbeitsspeicher)
allerdings hatte ich die druckbereich anpassung auskommentiert.
die dauert nämlich am längsten.
besser krieg ichs nicht.
rückmeldung wäre nett.
Option Explicit
Public
Sub Mach_alles()
Dim l As Long
Dim blatt As Integer
Dim plzahl As String
Dim Blt As String
Dim a As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For l = Range("H65536").End(xlUp).Row To 2 Step -1 'Blätter einfügen
If Left(Cells(l, 8), 2) = Left(Cells(l - 1, 8), 2) Then GoTo weiter
On Error Resume Next
plzahl = Left(CStr(Cells(l, 8).Text), 2)
Worksheets.Add After:=Worksheets(1) 'Anstatt "6012 Moordorf" eine 1 gesetzt
Worksheets(2).Name = "PLZ " & plzahl & "xx"
If Left(Worksheets(2).Name, 1) = "T" Then Worksheets(2).Delete 'hier anstatt T den ersten buchstaben deines tabellenblattes das eingefügt wird
weiter:
Next
a = 2
For blatt = 2 To Worksheets.Count 'überschriften holen
Worksheets(1).Range("a1:ab1").Copy
Worksheets(blatt).Range("a1:ab1").PasteSpecial Paste:=xlAll
Worksheets(blatt).Range("a1:ab1").PasteSpecial Paste:=xlPasteColumnWidths
For l = a To Worksheets(1).Range("H65536").End(xlUp).Row 'werte kopieren
plzahl = CStr(Left(Worksheets(1).Cells(l, 8).Text, 2))
Blt = Mid(CStr(Worksheets(blatt).Name), 5, 2)
If plzahl = Blt Then
Worksheets(1).Range(Cells(l, 1), Cells(l, 28)).Copy _
Destination:=Worksheets(blatt).Cells(Worksheets(blatt).Range("d65536").End(xlUp).Row + 1, 1)
End If
If plzahl > Blt Then
a = l
Exit For
End If
Next
Worksheets(blatt).Rows("2:" & Worksheets(blatt).Range("d65536").End(xlUp).Row + 1).RowHeight = 35 'zeilenhöhe einstellen
Next
'Call druckbereich 'druckbereich festlegen
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Sub druckbereich() 'Der Makrorekorder ist manchmal doch recht nützlich
Dim i As Integer
For i = 1 To Worksheets.Count
With Worksheets(i).PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.PrintArea = "$A$1:$AB$" & Worksheets(i).Range("d65536").End(xlUp).Row
.LeftHeader = ""
.CenterHeader = "Linz 4020 Gebiet 2" '? noch anpassen?
.RightHeader = ""
.LeftFooter = "VID:............................................"
.CenterFooter = "Bearbeitungswoche:............................"
.RightFooter = "Blatt &P von &N"
.LeftMargin = Application.InchesToPoints(0.275590551181102)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 300
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 52
.PrintErrors = xlPrintErrorsDisplayed
End With
Next
End Sub
ransi