Tabelle nach Filtern drucken

Hallo zusammen,
ich moechte gerne ein Makro schreiben, das automatisch jeweils auf eine Seite das Arbeitsblatt fuer einen Filter druckt.
Momentan wiederholt sich der folgende Code fuer jeden Kunden. Da es aber moeglich sein soll, staendig neue Kunden hinzuzufuegen/umzubenennen ohne das Makro anpassen zu muessen moechte ich dies aendern.
ActiveSheet.Unprotect
Selection.AutoFilter Field:=1, Criteria1:="Kunde 1"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Beim intensiven Suchen bin ich auf folgenden Link gestossen https://www.herber.de/mailing/Tabelle_nacheinander_filtern_und_drucken.htm
aber leider verstehe ich es nicht so ganz. Meine Excelkenntnisse sind ganz gut, aber ich bin ziemlich neu in VBA.
Die Spaltenueberschriften starten in Zeile 3. Der Filter ist in Spalte A (idealerweise sollte eigentlich sogar nach A und B gefiltert werden in Kombination aber ich kann auch einfach eine Hilfsspalte erstellen und die beiden Worte verketten, sodass dies dann als Filterspalte benutzt werden kann zum drucken)
Ich hoffe es ist verstaendlich. Ich freue mich ueber Loesungsvorschlaege.
https://www.herber.de/bbs/user/125473.xlsx
vielen Dank

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Zisa,
hier mein Versuch, der klappt:


Sub FilternUndDrucken()
Dim rg1 As Range, rg2 As Range
Dim dict As Object   'Dictionary
Dim jRow As Long, k As Variant
Worksheets("Template").Select
On Error Resume Next
'alle eventuellen Filtereinstellungen löschen
ActiveSheet.ShowAllData
On Error GoTo 0
'Speichermodell, in dem jeder Schlüsselwert(Kundenname) nur einmal _
aufgenmommen wird
Set dict = CreateObject("Scripting.Dictionary")
'alle Zellen des Filters in der Spalte 'A'
Set rg1 = Worksheets("Template").AutoFilter.Range.Columns(1)
'Überschrift des Filters & leetzte leere Zelle (A52) ausschließen
Set rg1 = rg1.Cells(2, 1).Resize(rg1.Cells.Count - 2)
'alle Zelle durchlaufen
For Each rg2 In rg1.Cells
If rg2.Row >= 4 And rg2.Value  "" Then
dict(rg2.Value) = 0
End If
Next rg2
'Werte des Dictionaries durchlaufen
For Each k In dict.Keys
With Worksheets("Template")
'Filter setzen
.Range(.AutoFilter.Range.Address).AutoFilter Field:=1, Criteria1:=k
.PrintPreview
End With
Next k
Worksheets("Template").Range("A1").AutoFilter
'Objektvariablen zerstören
Set dict = Nothing: Set rg1 = Nothing: Set rg2 = Nothing
End Sub

Gruß von Luschi
aus klein-Paris

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

199 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelle nach Filtern drucken

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

199 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread