Gruppe
Allgemein
Problem
Bei Eingaben in den Zellen F1, F2 oder F3 sollen die Werte in der Tabelle gefiltert und die sichtbaren Werte in die ListBox eingetragen werden.
ClassModule: Tabelle1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iCol As Integer
Dim sFilter As String
If Target.Cells.Count > 1 Then Exit Sub
iCol = Target.Column - 5
sFilter = Target.Value
If Intersect(Range("F2:H2"), Target) Is Nothing Then
Exit Sub
Else
Call GetFilter(iCol, sFilter)
Calculate
End If
End Sub
StandardModule: Modul1
Sub GetFilter(iColT As Integer, sFilterT As String)
Dim wks As Worksheet
Dim rng As Range, rngFilter As Range
Dim iCol As Integer
On Error GoTo ERRORHANDLER
Set wks = ActiveSheet
Set rng = Range("A1").CurrentRegion
rng.AutoFilter field:=iColT, Criteria1:="=" & sFilterT
Set rngFilter = rng.SpecialCells(xlCellTypeVisible)
Workbooks.Add 1
rngFilter.Copy Range("A1")
Rows(1).Delete
With Tabelle1.lstFilter
.Clear
.List = Range("A1").CurrentRegion.Value
End With
ActiveWorkbook.Close savechanges:=False
ERRORHANDLER:
wks.AutoFilterMode = False
Application.EnableEvents = True
If Err > 0 Then
Err.Clear
MsgBox "Es wurden keine Werte gefunden!"
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
ActiveWorkbook.Close savechanges:=False
ActiveSheet.AutoFilterMode = False
End If
End If
End Sub
Sub a()
Application.EnableEvents
End Sub