Bitte um Erweiterung eines Makros um einen Filter
07.06.2013 10:07:14
Jenny
würde mich sehr freuen, wenn ihr mir unter die Arme greift und unten stehendes Makro erweitert, sodass noch nach mehr Kriterien gefiltert wird.
Das Makro macht bislang folgendes:
1. ich mache händig einen Filter in die Tabelle Spalten A bis F
2. markiere eine oder mehrere Zellen in Spalte C, alle Zeilen mit dem markierten Inhalt in Spalte C sollen nach dem Filtern stehen bleiben
3. Mithilfe der Hilfsspalte B werden unter den übriggebliebenen Zeilen noch Duplikate in Spalte A ausgeblendet, unter Berücksichtigung dass 2 Zellen in Spalte A denselben Text aber unterschiedliche Hyperlinks haben können.
Nun jetzt zu meinem Wunsch. Punkt 3 soll ersetzt werden, dadurch dass von den Zeilen die nach Punkt 2 übrig bleiben, alle ausgeblendet werden, in denen die Zelle in Spalte E den Wert 0 hat.
Falls es von Belang ist, die Werte in E werden durch die Formel =ZÄHLENWENN(Tabelle3!A:Z;"*"&C2&"*"&D2&"*")+ZÄHLENWENN(Tabelle3!A:Z;"*"&D2&"*"&C2&"*") berechnet.
Vielen Dank für Eure Mühe
Jenny
Public Sub Jenny_Filtert()
Dim objRange As Range, objCell As Range, objArea As Range
Dim avntValue() As Variant
Dim ialngIndex As Long
Dim objDictionary As Object
If ActiveSheet.AutoFilterMode Then
If TypeOf Selection Is Range Then
Set objRange = Intersect(Selection, Columns(3))
If Not objRange Is Nothing Then
For Each objArea In objRange.Areas
For Each objCell In objArea
ReDim Preserve avntValue(ialngIndex)
avntValue(ialngIndex) = objCell.Value
ialngIndex = ialngIndex + 1
Next
Next
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.AutoFilter.Range.Rows(1).AutoFilter Field:=3, _
Criteria1:=avntValue, Operator:=xlFilterValues
Set objRange = Nothing
Set objRange = Autofilter_List(, True, False, True)
If Not objRange Is Nothing Then
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each objArea In objRange.Areas
For Each objCell In objArea.Columns(1).Cells
If Not objDictionary.Exists(objCell.Text) Then
Call objDictionary.Add(objCell.Text, vbNullString)
objCell.Offset(0, 1).Value = 1
Else
objCell.Offset(0, 1).Value = 0
End If
Next
Next
ActiveSheet.AutoFilter.Range.Rows(1).AutoFilter Field:=2, _
Criteria1:=1
Cells(1, 3).Select
Set objRange = Nothing
Set objDictionary = Nothing
End If
Else
MsgBox "Bitte Zellen in Spalte C auswählen.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Bitte Zellen in Spalte C auswählen.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Es ist kein Filter in der Tabelle.", vbExclamation, "Hinweis"
End If
End Sub
Private Function Autofilter_List( _
Optional ByRef probjSheet As Object = Nothing, _
Optional ByVal pvblnWithoutHeader As Boolean = True, _
Optional ByVal pvblnWholeRow As Boolean = True, _
Optional ByVal pvblnMessage As Boolean = False) As Range
If probjSheet Is Nothing Then Set probjSheet = ActiveSheet
If TypeOf probjSheet Is Worksheet Then
If probjSheet.AutoFilterMode Then
If probjSheet.FilterMode Then
With ActiveSheet.AutoFilter.Range.Offset(IIf(pvblnWithoutHeader, 1, 0))
With .Resize(.Rows.Count - IIf(pvblnWithoutHeader, 1, 0)).SpecialCells(xlCellTypeVisible)
If .Rows.Count > 1 Or .Areas.Count > 1 Then
Set Autofilter_List = .Cells
If pvblnWholeRow Then _
Set Autofilter_List = Autofilter_List.EntireRow
Else
If pvblnMessage Then _
MsgBox "Der Autofilter hat nichts gefunden.", vbExclamation, "Hinweis"
End If
End With
End With
Else
If pvblnMessage Then _
MsgBox "Kein Autofilter gesetzt.", vbExclamation, "Hinweis"
End If
Else
If pvblnMessage Then _
MsgBox "Kein Autofilter aktiv.", vbExclamation, "Hinweis"
End If
Else
If pvblnMessage Then _
MsgBox "Das Blatt ''" & probjSheet.Name & "'' ist keine Tabelle.", vbExclamation, "Hinweis"
End If
End Function