Re: Makro gesucht: Tabellenblätter automatisch mit bestimmten Daten füllen

thomas müller schrieb am 09.07.2008 08:33 Uhr:

In Tabellenblatt Total stehen ca. 10000 Zeilen. 1. Zeile ist eine Kopfzeile
In z.B. Spalte A stehen Zahlen. Jede Zahl ist einem Gebäude zugeordnet
(z.B. 1 Geb. A, 2 Geb. B, etc.).
Ich suche nun eine Möglichkeit zu überprüfen ob es auf Blatt Total in
Spalte A eine bestimmte Anzahl von XY 1ern, 2ern, 3ern, etc. gibt.
Wenn die gesuchten Werte mehr als XY mal vorhanden sind sollen alle
Zeilen mit 1ern (einschließlich Kopfzeile)auf ein neues Blatt kopiert
werden und das Blatt soll den Namen des gesuchten Wertes bekommen, also
1, 2, 3, etc.
Das soll sich solange wiederholen, bis alle Werte in Spalte A auf
separate Blätter aufgeteilt sind...

Der untestehende Code muss in den VBA-Bereich deiner Total-Tabelle.
Wenn Du ihn in einem Modul haben möchtest, musst Du überall "Me."
durch Sheets("Total"). ersetzen. Außerdem werden alle Blätter bis auf
"Total" gelöscht.

Peter

Sub total()
Dim zahlen As Object
Dim zahl As Variant
Dim sh As Variant
Dim i As Integer
Dim z As Long

Const XY = 1000

Set zahlen = CreateObject("Scripting.Dictionary")

For z = 2 To Cells(Rows.Count, "A").End(xlUp).Row
zahlen(Cells(z,"A").Value) = zahlen(Cells(z,"A").Value) + 1
Next

Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> Me.Name Then sh.Delete
Next
Application.DisplayAlerts = True

Me.Select
Rows("1:" & Cells(Rows.Count, "A").End(xlUp).Row).Select

For Each zahl In zahlen
If zahlen(zahl) > XY Then

For i = 2 To Sheets.Count
If zahl < Val(Sheets(i).Name) Then
Exit For
End If
Next
Sheets.Add After:=Sheets(i - 1)

With Sheets(i)
.Name = " " & zahl & " "
.Cells.ClearContents

Me.Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:=zahl
Selection.Copy

.Select
.[A1].Select
.Paste
.[A1].Select
End With

End If
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

Me.Select
Selection.AutoFilter
Me.[A1].Select

End Sub
.

Loading