AW: drucken mit Autofilter mit allen Kriterien
03.11.2009 12:44:38
Klaus
Hallo Joni,
filtert nacheinander Spalte A:
Option Explicit
Sub FilterAndPrint()
Dim ItemList As Variant, i As Integer
ThisWorkbook.Activate
Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
FindUniqueItems ItemList, "DataList"
ActiveSheet.Range("DataList").AutoFilter
For i = 1 To UBound(ItemList)
ActiveSheet.Range("DataList").AutoFilter 1, ItemList(i)
Application.StatusBar = "Printing report for " & ItemList(i)
'ActiveSheet.PrintOut ' commented out for demonstration purposes
ActiveSheet.PrintPreview ' comment out this line for proper use
Next i
Application.StatusBar = False
ActiveSheet.ShowAllData
End Sub
Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
' returns a list containing all unique items in the filter range
Dim TempList() As String, UniqueCount As Integer, cl As Range, i As Integer
Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
ReDim TempList(1 To UniqueCount - 1)
i = 0
For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
i = i + 1
If i > 1 Then TempList(i - 1) = cl.Formula ' ignore the heading
Next cl
Set cl = Nothing
UniqueItems = TempList
End Sub
Gruß
Klaus