Option Explicit
Dim lngInfoZeile As Long
Dim rngBereich As Range
Private Sub UserForm_Initialize()
Dim i As Integer
With Worksheets("Tabelle1")
Set rngBereich = .Range("A2:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub ComboBox1_Enter()
ComboBox1.List = SVERWEISSPECIAL(rngBereich, 1)
End Sub
Private Sub ComboBox1_Change()
TextBox1.Text = TB_fuellen
End Sub
Private Sub ComboBox2_Enter()
On Error Resume Next
ComboBox2.List = SVERWEISSPECIAL(rngBereich, 2, Array(1), Array(ComboBox1))
On Error GoTo 0
End Sub
Private Sub ComboBox2_Change()
TextBox1.Text = TB_fuellen
End Sub
Private Function TB_fuellen() As String
Dim ctrCTR As Control
Dim ctrCB As ComboBox
Dim strTBText As String
Dim ctrSpalte As Long
TB_fuellen = ""
ctrSpalte = 1
For Each ctrCTR In Me.Controls
If InStr(1, UCase(ctrCTR.Name), "COMBOBOX", vbBinaryCompare) <> 0 Then
Set ctrCB = ctrCTR
If ctrCB.ListIndex = -1 Then
Set ctrCB = Nothing
Exit Function
Else
Set ctrCB = Nothing
End If
End If
Next
For Each ctrCTR In Me.Controls
If InStr(1, UCase(ctrCTR.Name), "COMBOBOX", vbBinaryCompare) <> 0 Then
Set ctrCB = ctrCTR
strTBText = strTBText & ctrCB.List(ctrCB.ListIndex, ctrSpalte)
Set ctrCB = Nothing
End If
Next
TB_fuellen = strTBText
End Function
Private Function SVERWEISSPECIAL(Matrix As Range, AusgabeSpalte As Integer, Optional KriteriumSpalten As Variant = 0, Optional KriteriumWerte As Variant = 0) As Variant
Dim arr As Variant
Dim DicOut As Object
Dim strVgl1 As String
Dim strVgl2 As String
Dim i As Long
Dim k As Long
On Error GoTo Ende
Set DicOut = CreateObject("Scripting.Dictionary")
arr = Matrix.Value
If Not IsArray(KriteriumSpalten) Or Not IsArray(KriteriumWerte) Then
For i = 1 To UBound(arr)
If arr(i, AusgabeSpalte) <> "" Then _
DicOut(arr(i, AusgabeSpalte)) = ""
Next
Else
For k = 0 To UBound(KriteriumWerte)
strVgl1 = strVgl1 & "'#$#" & KriteriumWerte(k)
Next
For i = 1 To UBound(arr)
strVgl2 = ""
For k = 0 To UBound(KriteriumSpalten)
strVgl2 = strVgl2 & "'#$#" & arr(i, KriteriumSpalten(k))
Next
If arr(i, AusgabeSpalte) <> "" Then _
If strVgl1 = strVgl2 Then _
DicOut(arr(i, AusgabeSpalte)) = ""
Next
End If
If DicOut.Count > 0 Then
arr = DicOut.Keys
QSort arr, LBound(arr), UBound(arr)
SVERWEISSPECIAL = arr
End If
Exit Function
Ende:
SVERWEISSPECIAL = ""
End Function
Sub QSort(ByRef arr, low, hi)
Dim i, j, p
While low < hi
p = arr(hi)
i = low - 1
For j = low To hi - 1
If arr(j) <= p Then
i = i + 1
Swap arr, i, j
End If
Next
Swap arr, i + 1, j
QSort arr, low, i
low = i + 2
Wend
End Sub
Sub Swap(ByRef arr, first, second)
Dim t
t = arr(first)
arr(first) = arr(second)
arr(second) = t
End Sub