Es geht darum, dass das Makro nur Zeilen anzeigt, deren Wert in Spalte E größer 0 ist, also quasi das Ergebnis des unten stehenden Makros nochmal gefiltert wird nach E größer 0.
Seid ihr bitte so nett und helft mir?
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