AW: Autofilter über mehrere Tabellenblätter
21.05.2008 19:45:00
Renee
Hi Markus,
Ok. Der Code kann theoretisch in jedes Blatt mit Namen Werk_ kopiert werden. Er setzt alle Autofilter in diesen Blättern gleich (bei Doppelklick in die Zelle A1), wie das jeweilige aktive 'Werk_'Blatt.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim iX As Integer, iXF As Integer
Dim arrFilter()
If Target.Address "$A$1" Then Exit Sub
Cancel = True
Application.EnableEvents = False
With ActiveSheet.AutoFilter
With .Filters
ReDim arrFilter(1 To .Count, 1 To 3)
For iXF = 1 To .Count
With .Item(iXF)
If .On Then
arrFilter(iXF, 1) = .Criteria1
If .Operator Then
arrFilter(iXF, 2) = .Operator
arrFilter(iXF, 3) = .Criteria2
End If
End If
End With
Next
End With
End With
For iX = 1 To ActiveWorkbook.Worksheets.Count
If Left(ActiveWorkbook.Worksheets(iX).Name, 5) = "Werk_" And _
ActiveWorkbook.Worksheets(iX).Name ActiveSheet.Name Then
With ActiveWorkbook.Worksheets(iX)
On Error Resume Next
.ShowAllData
On Error GoTo 0
For iXF = 1 To UBound(arrFilter(), 1)
If Not IsEmpty(arrFilter(iXF, 1)) Then
If arrFilter(iXF, 2) Then
.Range("A1:C1").AutoFilter field:=iXF, Criteria1:=arrFilter(iXF, 1), _
Operator:=arrFilter(iXF, 2), Criteria2:=arrFilter(iXF, 3)
Else
.Range("A1:C1").AutoFilter _
field:=iXF, Criteria1:=arrFilter(iXF, 1)
End If
End If
Next iXF
End With
End If
Next iX
MsgBox " Autofilter auf allen Blättern" & vbCrLf & _
"gemäss Blatt " & ActiveSheet.Name & " gesetzt!", _
vbOKOnly + vbInformation, "Auto-Autofilter"
Application.EnableEvents = True
End Sub
GreetZ Renée