Permutation ohne Wiederholung auflisten

Const strDelim As String = "|"
Sub SpaltenKombinieren()
Application.ScreenUpdating = False
Dim objKombi As Object, rngC As Range, lngCount As Long
Dim arrKombi(), arrTmp, i As Long, j As Long
Dim colKombi As New Collection
Set objKombi = CreateObject("Scripting.Dictionary")
For Each rngC In Range("A:C").Columns
colKombi.Add _
Range(Cells(1, rngC.Column), Cells(Rows.Count, rngC.Column).End(xlUp)).Value
Next
Kombinieren_a colKombi, , objKombi
If objKombi.Count > Rows.Count - 1 Then
MsgBox "Zu viele Kombinationen (" & objKombi.Count & ")", , "Fehler"
Else
ReDim arrKombi(1 To objKombi.Count, 1 To colKombi.Count)
For i = 1 To objKombi.Count
arrTmp = Split(objKombi(i), strDelim)
For j = 1 To colKombi.Count
arrKombi(i, j) = arrTmp(j - 1)
Next j
Next i
Workbooks.Add (1)
Sheets(1).Cells(1, 1).Resize(UBound(arrKombi), UBound(arrKombi, 2)) = arrKombi
End If
Set objKombi = Nothing
For lngCount = 1 To colKombi.Count
colKombi.Remove 1
Next
Application.ScreenUpdating = True
End Sub
Sub Kombinieren_a(colKombi, Optional strAusgabe As String, Optional objKombi)
Dim i As Long, arrValues, j As Integer
Static lngStep As Long
lngStep = lngStep + 1
If IsArray(colKombi(lngStep)) Then
For i = 1 To UBound(colKombi(lngStep))
If lngStep  0 Then
ReDim arrTmp(UBound(arrValues) - 1)
For i = 0 To UBound(arrValues)
If strErg = "" Then
strTmp = arrValues(i)
Else
strTmp = strErg & strDelim & arrValues(i)
End If
k = 0
For j = 0 To UBound(arrValues) - 1
If i = j Then k = 1
arrTmp(j) = arrValues(j + k)
Next j
Kombinieren_b arrTmp, strTmp, objErg
Next i
Else
objErg(objErg.Count + 1) = strErg & strDelim & arrValues(0)
End If
End Sub