Address - Filter - Find!

Der Autofilter filtert über VBA Adressdaten. Auf Tabellenblatt 2 und 3 werden die nicht passenden Zeilen über die Find-Funktion ausgeblendet. In Tabellenblatt 3 können mehrere Suchbegriffe kommagetrennt einegegeben werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Tabelle1, Tabelle2 und Tabelle3".


Option Explicit
Public Sub CommandButton1_Click()
Dim objButton As OLEObject
For Each objButton In ActiveSheet.OLEObjects
If Left(objButton.Name, 7) = "TextBox" Then
objButton.Object.Value = ""
End If
Next objButton
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
Private Sub TextBox1_Change()
If TextBox1.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=1, Criteria1:="=" _
& Me.TextBox1 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=1, Criteria1:="**" _
' & Me.TextBox1 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox2_Change()
If TextBox2.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=2, Criteria1:="=" _
& Me.TextBox2 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=2, Criteria1:="**" _
' & Me.TextBox2 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox3_Change()
If TextBox3.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=3, Criteria1:="=" _
& Me.TextBox3 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=3, Criteria1:="**" _
' & Me.TextBox3 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox4_Change()
If TextBox4.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=4, Criteria1:="=" _
& Me.TextBox4 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=4, Criteria1:="**" _
' & Me.TextBox4 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strFirst As String
Dim lngColumn As Long
Dim rngUnion As Range
Dim rngFound As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
If Trim(Target.Value) = "" Then _
Cells.EntireRow.Hidden = False: Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
lngRow = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, _
Cells(Rows.Count, 1).End(xlUp).Row)
lngColumn = Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngTMP = Range(Cells(3, 1), Cells(lngRow, lngColumn))
Set rngFound = rngTMP.Find(Cells(1, 2).Text, _
After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngUnion Is Nothing Then
Set rngUnion = Application.Union(rngUnion, _
Cells(rngFound.Row, 1)).EntireRow
Else
Set rngUnion = Cells(rngFound.Row, 1).EntireRow
End If
Set rngFound = rngTMP.FindNext(rngFound)
Loop While rngFound.Address <> strFirst
Else
Target.ClearContents
MsgBox "Nothing found!"
End If
Else
Exit Sub
End If
Application.Goto Range("B1")
If Not rngUnion Is Nothing Then
rngTMP.Rows.Hidden = True
rngUnion.Hidden = False
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
Set rngUnion = Nothing
Set rngFound = Nothing
Set rngTMP = Nothing
End Sub


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strFirst As String
Dim varTerm As Variant
Dim intTMP As Integer
Dim lngColumn As Long
Dim rngUnion As Range
Dim rngFound As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
If Trim(Target.Value) = "" Then _
Cells.EntireRow.Hidden = False: Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
lngRow = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, _
Cells(Rows.Count, 1).End(xlUp).Row)
lngColumn = Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngTMP = Range(Cells(3, 1), Cells(lngRow, lngColumn))
varTerm = Split(Cells(1, 2).Text, ",")
For intTMP = 0 To Ubound(varTerm)
Set rngFound = rngTMP.Find(varTerm(intTMP), _
After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngUnion Is Nothing Then
Set rngUnion = Application.Union(rngUnion, _
Cells(rngFound.Row, 1)).EntireRow
Else
Set rngUnion = Cells(rngFound.Row, 1).EntireRow
End If
Set rngFound = rngTMP.FindNext(rngFound)
Loop While rngFound.Address <> strFirst
Else
Target.ClearContents
MsgBox "Nothing found!"
End If
Next intTMP
Else
Exit Sub
End If
Application.Goto Range("B1")
If Not rngUnion Is Nothing Then
rngTMP.Rows.Hidden = True
rngUnion.Hidden = False
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
Set rngUnion = Nothing
Set rngFound = Nothing
Set rngTMP = Nothing
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...