Sub Testen()
Dim strMaterial As String
Dim arrV() As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMaterial = InputBox("Ihre Auswahl")
If Len(strMaterial) < 1 Then Exit Sub
HilfsArbeitsmappe "Hilfstabelle"
arrV = Unikatliste("Tabelle4", "Hilfstabelle", "E", "I", strMaterial)
Sheets("Hilfstabelle").Delete
MsgBox Join(arrV, vbNewLine)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function Unikatliste(strA As String, strH As String, _
colM As String, colD As String, strMat As String) As Variant
Dim ShA As Excel.Worksheet
Dim ShH As Excel.Worksheet
Dim rngF As Range, rngA As Range, rngR As Range, c As Range
Dim strarr As String, vArr() As String, i As Integer
Set ShA = Sheets(strA)
Set ShH = Sheets(strH)
With ShH
.AutoFilterMode = False
.Cells.Clear
ShA.Columns(colM).Copy .Range("A1")
ShA.Columns(colD).Copy .Range("B1")
With .UsedRange.Columns("C")
.FormulaR1C1 = "=RC[-2]&RC[-1]"
.Value = .Value
End With
.UsedRange.RemoveDuplicates Columns:=3, Header:=xlNo
.UsedRange.AutoFilter Field:=3, Criteria1:= _
"=" & strMat & "*", Operator:=xlAnd
Set rngF = .UsedRange.SpecialCells(12)
For Each rngA In rngF.Areas
For Each rngR In rngA.Rows
If rngR.Cells(1).Value = strMat Then
ReDim Preserve vArr(0 To i)
vArr(i) = rngR.Cells(2).Value
i = i + 1
End If
Next rngR
Next rngA
End With
Unikatliste = vArr
End Function
Private Sub HilfsArbeitsmappe(strName As String)
Dim Sh As Excel.Worksheet
For Each Sh In Sheets
If Sh.Name = strName Then Exit For
Next Sh
If Sh Is Nothing Then
Sheets.Add
ActiveSheet.Name = strName
End If
End Sub