Excel VBA Mögliche Kombinationen

[sharky51]

Hallo zusammen,

in einer Liste habe ich eine unterschiedliche Anzahl von Namen...als Beispiel sagen wir mal 10 Namen die in der Spalte "A" aufgelistet sind.
Ich möchte nun aus diesen Namen alle Namenskombinationen herausfinden und dazu habe ich einen super VBA-Code von ransi gefunden der das perfekt macht.

Code:

Option Explicit

Public Sub test()
Dim myDic
Dim Arr
Dim L As Long
Dim S As Long
Dim K
Dim SPL
Set myDic = CreateObject("Scripting.Dictionary")
Arr = Range("A1:A10")
For L = 1 To UBound(Arr) - 1
   For S = L + 1 To UBound(Arr)
       myDic(Arr(L, 1) & " " & Arr(S, 1)) = 0
   Next
Next
Range("B1").Resize(myDic.Count) = WorksheetFunction.Transpose(myDic.keys)
K = myDic.keys
myDic.removeall
For L = LBound(K) To UBound(K)
   For S = LBound(K) To UBound(K)
       SPL = Split(K(L), " ")
       If Not K(S) Like "*" & SPL(0) & "*" Then
           If Not K(S) Like "*" & SPL(1) & "*" Then
               If Not myDic.exists(K(S) & "--" & K(L)) Then
                   If Not myDic.exists(K(L) & "--" & K(S)) Then
                       myDic(K(L) & "--" & K(S)) = 0
                   End If
               End If
           End If
       End If
   Next
Next
Range("C1").Resize(myDic.Count) = WorksheetFunction.Transpose(myDic.keys)
End Sub

Was ich nun gerne noch als Highlight hätte ist die Möglichkeit aus einer gefilterten Liste... es bleiben nur noch z.B. 6 Namen übrig... der Rest wird mittels Autofilter ausgeblendet...alle möglichen Kombinationen aufgelistet zu bekommen.

Leider gelingt es mir nicht zu einem richtigen Ergebnis zu kommen.
Dies hier bringt mich auch nicht weiter. Autofilter ist anscheinend ein größeres Problem.

Code:

arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)

Ach ja, in Spalte "B" wird jeweils noch eine Platzziffer dem jeweiligen Namen zugeordnet. In Spalte "D" soll dann die Addition der Platzziffern aus der jeweiligen Kombination eingetragen werden.


Tabelle

	A	B
1	Name	Platzziffer
2	Name1	1
3	Name2	2
4	Name3	3
5	Name4	4
6	Name5	5
7	Name6	6
8	Name7	7
9	Name8	8
10	Name9	9
11	Name10	10

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.08 einschl. 64 Bit

Vielleicht habt Ihr noch einen Lösungsweg der zum Ziel führt?

Dafür vielen Dank schonmal! Das wäre super!

[Steffl]

Hallo Erich,

könntest Du deine Datei hier hochladen?

[sharky51]

Hallo Stefan,

siehe beigefügte Datei.

[Steffl]

Hallo Erich,

warum hier

Code:

For L = 1 To UBound(arr) - 1
    For S = L + 1 To UBound(arr)
        myDic(arr(L, 1) & " " & arr(S, 1)) = 0
    Next
Next

2 Schleifen?

[sharky51]

Hallo Stefan,

das ist ne gute Frage. Wie ich schon geschrieben hatte ist dieses für mich trickreiche Makro von ransi geschrieben.
Wäre froh wenn ich so manche Codezeile auch verstehen würde.

Ich kann Dir deshalb keine Antwort auf Deine Frage geben.

[Steffl]

Hallo Erich,

versuchs mal so

Code:

Public Sub test()
Dim myDic
Dim arr
Dim L As Long
Dim S As Long
Dim lngC As Long, lngA As Long
Dim K
Dim SPL
Dim Bereich As Range

Set myDic = CreateObject("Scripting.Dictionary")

lngC = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells.Count
ReDim arr(1 To lngC, 1 To 1)
lngA = 1
For Each Bereich In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells
    arr(lngA, 1) = Bereich
    lngA = lngA + 1
Next Bereich
For L = 1 To UBound(arr) - 1
    For S = L + 1 To UBound(arr)
        myDic(arr(L, 1) & " " & arr(S, 1)) = 0
    Next
Next
Range("C2").Resize(myDic.Count) = WorksheetFunction.Transpose(myDic.keys)
K = myDic.keys
myDic.RemoveAll
For L = LBound(K) To UBound(K)
    For S = LBound(K) To UBound(K)
        SPL = Split(K(L), " ")
        If Not K(S) Like "*" & SPL(0) & "*" Then
            If Not K(S) Like "*" & SPL(1) & "*" Then
                If Not myDic.exists(K(S) & "--" & K(L)) Then
                    If Not myDic.exists(K(L) & "--" & K(S)) Then
                        myDic(K(L) & "--" & K(S)) = 0
                    End If
                End If
            End If
        End If
    Next
Next
'Range("E1").Resize(myDic.Count) = WorksheetFunction.Transpose(myDic.keys)
End Sub