Option Explicit
Sub Tabelle_Filtern()
Dim lngZeileMax As Long
Dim tblA As Worksheet
Dim arrCriteria() As String
Dim lngCriteriaCount As Long
Dim rngFilterRange As Range
Dim lngFilterRow As Long, lngFilterColumn As Long
Dim lngFilter As Long
Dim loLetzte As Long
With Worksheets("filter_criteria")
loLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
End With
Set tblA = Worksheets("Raw_Data_with_8D")
Application.ScreenUpdating = False
With tbl_Daten
lngCriteriaCount = loLetzte
ReDim arrCriteria(0 To lngCriteriaCount - 1)
arrCriteria(0) = "mechanical"
arrCriteria(1) = "damage"
arrCriteria(2) = "connector"
arrCriteria(3) = "housing"
arrCriteria(4) = "bracket"
rngFilterRange.AutoFilter Field:=67, _
Criteria1:=arrCriteria(), _
Operator:=xlFilterValues
With Worksheets("Raw_Datas_with_8D")
If .AutoFilterMode Then
If .FilterMode Then
With .AutoFilter
lngFilterRow = .Range.Row
lngFilterColumn = .Range.Column
With .Filters
For lngFilter = 1 To .Count
If .Item(lngFilter).On Then Exit For
Next
End With
End With
.Range(.Range(.Cells(lngFilterRow + 1, lngFilterColumn), _
.Cells(lngFilterRow + 1, _
lngFilterColumn + .AutoFilter.Filters.Count - 1)), _
.Cells(lngFilterRow, lngFilter).End(xlDown)).Copy _
Worksheets("duplicates_deleted").Range("A1")
Else
MsgBox "Der Autofilter ist nicht gesetzt.", 48, "Hinweis"
End If
Else
MsgBox "Kein Autofilter in der Tabelle.", 48, "Hinweis"
End If
End With
With Worksheets("Raw_Datas_with_8D")
If .AutoFilterMode Then
If .FilterMode Then
.ShowAllData
End If
End If
End With
End With
End Sub