Genau sowas habe ich
16.02.2011 14:33:16
Holger,
Hallo,
mithilfe dieses Forums habe ich folgenden Code erstellt.
Es wird ein Spezialfilter benutzt, dazu muss man einen Hilfsrange definieren.
Ist etwas kompliziert. Lass es einfach mal im Einzelmodus laufen und
bei Fragen, melde Dich.
Im Tabellenblatt diesen Code
Sub Sheet
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = "$B$4" Then
Call DoAdvancedFilter(Target.Value)
end sub
Dann die Funktion DoAdvancedFilter mit Parameterübergabe.
Bei mir sind die Values im Zellinhalt durch ein Blank getrennt,
das musst du anpassen. Wenn in der Zelle HOLGER HALLO steht
wird auch auf diese Werte gefiltert.
Function DoAdvancedFilter(ByVal CRITERIA As String)
Dim rngCrit As Range
Dim arrCrit
Dim strCriteria As String, intLen As Integer, strFilterMessage As String
strCriteria = Mid(CRITERIA, (InStr(CRITERIA, ":") + 2))
intLen = Len(strCriteria)
If intLen > 1 Then
strCriteria = Left(strCriteria, intLen - 1)
strFilterMessage = "Filterung auf: " & strCriteria
Else
strFilterMessage = "Keine Filterung möglich!"
Range("B10").Activate
End
End If
arrCrit = Split(strCriteria, " ") 'Argumente in ein Array
Set rngCrit = Range("AA10").Resize(UBound(arrCrit) + 2) 'Überschrift + Argumente
With Application
.ScreenUpdating = False
.EnableEvents = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
With rngCrit
.Font.Color = vbWhite
.Cells(1, 1).Value = Cells(10, 2).Value 'Überschrift von B2 in die _
erste Zelle des Range kopieren
.Cells(2, 1).Resize(UBound(arrCrit) + 1) = Application.Transpose(arrCrit) ' _
Argumente
With Range("B10", Cells(Rows.Count, 2).End(xlUp)) 'Filterbereich Spalte B
.AdvancedFilter xlFilterInPlace, rngCrit
End With
.Clear 'Hilfszellen löschen
End With
.EnableEvents = True
.ScreenUpdating = True
End With
Range("B10").Activate
End Function