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

On 10 Jul., 09:23, thomas müller <thm2342...@xxxxxxx> wrote:

Könntest Du mir
bitte sagen, wo ich überall was ändern muss wenn die
gesuchten Werte
nicht in Spalte A sonder in einer anderen Spalte stehen?

Im neuen Code gibt es dafür eine weitere Konstante:

Const SPALTE = 1 '/Spalte A/


Wäre es unverschämt zu fragen ob das gleich auch funktionieren
würde wenn nicht Zahlen gesucht Werden sondern Buchstaben
wie A, B, C, oder Worte wie AB1, Ab2, etc? :)

Das funktioniert mit dem Dictionary problemlos.

Ich habe außerdem das Löschen der Blätter beschränkt. Es werden jetzt
nur noch diejenigen gelöscht, die tatscählich in Liste auftauchen,
aber eben nicht in genügender Anzahl. Wenn Du ein extra Blatt
möchtest, mit einer Übersicht der Zahlen/Buchstaben und ihrer
Häufigkeit, melde dich bitte nochmal.

Peter


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

Const XY = 5 '/Schwellenwert/
Const SPALTE = 1 '/Spalte A/

Set zahlen = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False

Me.Select
Me.AutoFilterMode = False
Range(Cells(1, SPALTE), _
Cells(Cells(Rows.Count, SPALTE).End(xlUp).Row, _
Cells.SpecialCells(xlCellTypeLastCell).Column)).Select

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

For Each zahl In zahlen

Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name = " " & zahl & " " Then sh.Delete
Next
Application.DisplayAlerts = True

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

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

Me.Select
Me.AutoFilterMode = False
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
Me.AutoFilterMode = False
Me.[A1].Select

End Sub
.