AW: virtuelle Tabelle
09.08.2011 08:46:05
fcs
Hallo Berny,
der Vorschlag von ransi funktioniert leider nicht, da nach ShowAllData auch die Daten in der Objektvariablen zurückgesetzt werden.
Du muss die Filterdaten in einem Datenarray zwischenspeichern.
Hier ein Beispiel zum Speicher und erneutem setzen des Filters. Die testausgabe in eine Tabelle kannst du natürlich löschen.
Gruß
Franz
Option Explicit
Dim arrFD As Variant
Sub AFilter()
Dim f As Filter, iIndex As Long
Dim w As Worksheet, w2 As Worksheet
Dim c1, c2, op, Spalte As Long, rw As Long
On Error Resume Next
Const ns = "Not set"
Set w2 = Worksheets("Tabelle1")
Set w = Worksheets("FilterData")
If w.AutoFilterMode = True Then
ReDim arrFD(1 To w.AutoFilter.Filters.Count, 1 To 4)
For iIndex = 1 To w.AutoFilter.Filters.Count
Set f = w.AutoFilter.Filters(iIndex)
c1 = ns
op = ns
c2 = ns
If f.On Then
c1 = f.Criteria1
If f.Operator Then
op = f.Operator
c2 = f.Criteria2
End If
End If
arrFD(iIndex, 1) = w.AutoFilter.Range.Cells(1, iIndex).Text 'Spaltentitel
arrFD(iIndex, 2) = c1
arrFD(iIndex, 3) = op
arrFD(iIndex, 4) = c2
Next
If w.FilterMode = True Then
w.AutoFilter.ShowAllData
End If
'Filterdaten zum Testen in Tabelle schreiben
rw = 1
With w2
.UsedRange.Clear
.Cells(rw, 1) = "Spalte"
.Cells(rw, 2) = "Kriterium 1"
.Cells(rw, 3) = "Operator"
.Cells(rw, 4) = "Kriterium 2"
For iIndex = 1 To UBound(arrFD, 1)
rw = rw + 1
For Spalte = 1 To 4
Select Case Spalte
Case 1, 3, 4
.Cells(rw, Spalte) = "'" & arrFD(iIndex, Spalte)
Case 2
If IsArray(arrFD(iIndex, Spalte)) Then
.Cells(rw, Spalte) = "'" & "Werte-Liste"
Else
.Cells(rw, Spalte) = "'" & arrFD(iIndex, Spalte)
End If
End Select
Next
Next
.Columns.AutoFit
End With
Else
MsgBox "Autofilter ist nicht aktiv"
End If
End Sub
Sub filter_wiederherstellen()
Dim f As Filter, iIndex As Long, oAutofilter As AutoFilter
Dim w As Worksheet
Const ns = "Not set"
Set w = Worksheets("FilterData")
If w.AutoFilterMode = True Then
With w.AutoFilter.Range
For iIndex = 1 To w.AutoFilter.Filters.Count
If arrFD(iIndex, 2) ns And arrFD(iIndex, 3) ns And arrFD(iIndex, 4) ns Then
.AutoFilter Field:=iIndex, Criteria1:=arrFD(iIndex, 2), _
Operator:=arrFD(iIndex, 3), Criteria2:=arrFD(iIndex, 4)
ElseIf arrFD(iIndex, 2) ns And arrFD(iIndex, 3) ns Then
.AutoFilter Field:=iIndex, Criteria1:=arrFD(iIndex, 2), _
Operator:=arrFD(iIndex, 3)
ElseIf arrFD(iIndex, 2) ns Then
.AutoFilter Field:=iIndex, Criteria1:=arrFD(iIndex, 2)
End If
Next
End With
Else
MsgBox "Autofilter ist nicht aktiv"
End If
End Sub