Option Explicit
Sub FilterVersion()
Dim x As Long 'Areas-Counter und ReDim für vSendungsnummern
Dim c As Excel.Range 'For-Each-Zelle als Sammler der Sendungsnummern
Dim rng As Excel.Range 'Filterbereich
Dim rngIsect As Excel.Range 'Schnittmenge gefilterter Bereich (Sendungsnummern); liefert Input für den Sammler
Dim wks As Excel.Worksheet 'Intellisense
Dim vSuchwerte() As Variant 'Codes 1650, 5940, 5950
Dim vSendungsnummern() As Variant '
'*** Intellisense
Set wks = ActiveSheet
'*** Deine gesuchten Codes
vSuchwerte = Array("1650", "5940", "5950")
'*** Bereich ermitteln
With wks
If .AutoFilterMode Then .AutoFilterMode = False
Set rng = .Range("A1:C" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ Bereich anpassen
End With
'*** Filtern und Schnittmenge als Range-Objekt
rng.AutoFilter Field:=2, Criteria1:=vSuchwerte, Operator:=xlFilterValues 'Filtern anhand der Codes
Set rngIsect = Intersect(rng, rng.Offset(1), rng.SpecialCells(xlCellTypeVisible)) 'Range-Objekt bilden um Sendungsnummern einzusammeln
'*** Sendungsnummern ermitteln
If Not rngIsect Is Nothing Then
ReDim vSendungsnummern(1 To rngIsect.Areas.Count) 'Anzahl Sendungsnummern; mit Doppler(!)
For x = 1 To rngIsect.Areas.Count
For Each c In rngIsect.Areas(x).Columns(1)
vSendungsnummern(x) = c.Value
Next
Next x
End If
'*** Anhand Sendungsnummern YES/NO
rng.AutoFilter Field:=2
rng.AutoFilter Field:=1, Criteria1:=vSendungsnummern, Operator:=xlFilterValues
End Sub
Der oben gezeigte Code orientiert sich an folgender Tabelle:
|