Ich möchte für eine beliebige Anzahl von vorgegebenen Werten, alle möglichen Kombinationen ermitteln. Also z.B. für 4 Werte alle möglichen 1er,2er,3er und 4er Paare.

Ergebnis müsste dann ungefähr so aussehen:

1; 2; 3; 4
1_2; 1_3; 1_4; 2_3; 2_4; 3_4
1_2_3; 1_2_3; 1_3_4; 2_3_4
1_2_3_4

Für die 2er Paare bekomm ich's noch einfach hin - aber für alle Kombinationen hab ich grad keine Idee.

Unter dem Stichwort Permutation findet ja man schon einiges. Aber es wird immer davon ausgegangen, dass ich bei 3 Werten auch immer 3er Kombinationen haben möchte. Ich brauche aber auch alle 1er, 2er Kombinationen.

Bin etwas weiter gekommen, ist aber nicht 100%

PHP-Code:

Public Function Test()
    Dim wert(1 To 5), i As Integer, max As Integer, y As Integer, start As Integer, x As Integer, y_ As Integer, z As Integer, z_ As Integer, max_ As Integer
    
    wert(1) = 1
    wert(2) = 2
    wert(3) = 3
    wert(4) = 4
    wert(5) = 5
    max = 5
    
    For x = 1 To (max - 2)
        For i = 1 To (max - 1)
            max_ = max
            If (i + x) > max Then
                max_ = max + x - 1
            End If
            For y = (i + x) To (max_)
                y_ = y
                If y > max Then
                    y_ = y - max
                End If
                    For z = i To (i + x - 1)
                        z_ = z
                        If z > max Then
                            z_ = z - max
                        End If
                        Debug.Print wert(z_)
                    Next z
                Debug.Print wert(y_)
            Debug.Print "#"
            Next y
            Debug.Print "#"
        Next i
    Next x
    
    
    
End Function 


Hallo Roman,

Wenn die Menge der Elemente die gefunden werden soll immer gleich ist, ist das Verfahren einfach. Für 3 Elemente sieht es z. B. so aus:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26

Sub Kombinationen_3()   'Beispiel für 3 Element aus der Menge 'Wert()'     Dim iUG As Integer                    ' untere Array Grenze   Dim iOG As Integer                    ' obere Array Grenze   Dim iZahler_1 As Integer              ' Zähler   Dim iZahler_2 As Integer              ' Zähler   Dim iZahler_3 As Integer              ' Zähler     Dim wert(1 To 5) As Integer     wert(1) = 1     wert(2) = 2     wert(3) = 3     wert(4) = 4     wert(5) = 5     iUG = LBound(wert())   iOG = UBound(wert())   For iZahler_1 = iUG To iOG     For iZahler_2 = iZahler_1 + 1 To iOG       For iZahler_3 = iZahler_2 + 1 To iOG         Debug.Print wert(iZahler_1), wert(iZahler_2), wert(iZahler_3)       Next iZahler_3     Next iZahler_2   Next iZahler_1 End Sub

Dieses Verfahren ist leider nicht flexibel. Für eine andere Anzahl Elemente muss die Prozedur geändert werden.
Ob ich einen allgemeingütigen Algorithmus (n Element aus einer Menge m) hinbekomme versuche ich noch.

Viel Erfolg
Walter Gutermann

Hallo Roman,

das war eine schöne Aufgabe. Hier nun meine Vorstellung von einem universellen Algorithmus:

Anzahl der Kombinationen non N Elementen aus einer Menge von M Elementen (ohne Wiederholung).

- Initiiere Anfangspositionen
(pos(1) = 1; pos(2) = 2; ….pos(N) = N)

- Start der Schleife

- iStart = pos(N – 1), = vorletzte Position

- Erhöhe Position letztes Element pos(N) = iStart +1 bis M
pos(N) = iStart +1
pos(N) = iStart + 2
bis
pos(N) = M

--> hier Ausgabe der Werte

- Stelle fest wie viel Elemente ihre Endposition erreicht haben
= iAnzEndPos

- erhöhe Element (N – iAnzEndPos) um 1

- Aktualisiere die Positionen der nachfolgenden Elementen von
Element (N – iAnzEndPos). Jedes nachfolgende Element ist um 1 höher als sein Vorgänger.
pos(N – iAnzEndPos + 1) = pos(N – iAnzEndPos ) + 1
bis
pos(N) = pos(N – 1) + 1

- Tue das so lange, bis alle Elemente ihre Endposition erreicht haben
(iAnzEndPos = N)


Bitte melde Dich wenn Du den Algorithmus umgesetzt hast.

Viel Erfolg
Walter Gutermann

NS: In meiner ersten Antwort habe ich noch einen Schönheitsfehler entdeckt. Die beiden äußere Schleifen machen einige Null - Durchgänge. Das Schleifenende kann um 2 bzw. 1 gekürzt werden.

Hi,
die schnellste Variante ist folgende:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer Dim  n As Long n = 0   For a = 1 To 1   For b = a + 1 To 2     For c = b + 1 To 3       For d = c + 1 To 4         For e = d + 1 To 5             n = n + 1           Next e         Next d       Next c     Next b   Next a

Die 2er Kombination ergibt 10 Möglichkeiten ohne Wiederholung.
Welche Kombinationen o.W. Du auch immer suchst, in Excel kannst Du die Anzahl der Möglichkeiten relativ leicht ermitteln.
Grüße

Hallo Alfred,
getestet hast Du das aber nicht, oder?

Grüße
Walter

Hi, natürlich. Seit einiger Zeit schon!
Grüße
PS.: Das ist nur das Grundgerüst. Das Schreiben in einer Datei etc. fehlt natürlich und es werden ALLE Kombinationen aus den Zahlen 1 - 5 generiert. Wenn Du allerdings die Auswahlzahlen selbst definieren möchtest, dann ist diese Variante nicht zutreffend.

Hallo Alfred,

in Deinem Beispiel wird jede Schleife genau 1mal durchlaufen (Schleife a von 1 nach 1, Schleife b von 2 nach 2, …). Das Ergebnis ist, dass n von 0 auf 1 erhöht wird. Mehr geschieht nicht.

Grüße
Walter Gutermann

Hi,
Deine Kritik zu DIESEM Beispiel ist richtig. Ich wollte Dir nur das Grundgerüst vermitteln.
Der Code 5aus2 muss lauten!

Code :

1 2 3 4 5

For a = 1 To 4   For b = a + 1 To 5    n = n + 1   Next b  Next a

Solltest Du 6aus49 mit 13,983.816 Kombinationen o.W.
generieren wollen, dann geht das so:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13

For a = 1 To 44   For b = a + 1 To 45     For c = b + 1 To 46       For d = c + 1 To 47         For e = d + 1 To 48           For f = e + 1 To 49             n = n + 1             Next f           Next e         Next d       Next c     Next b   Next a

Eine schnellere Routine ist mir nicht bekannt. Alles klar?
Grüße

Hallo zusammen,

danke für die Tipps. Die Lösung ist ein rekursiver Algorithmus, der aber auch nicht von mir persönlich kommt. Damit lassen sich alle Kombinationen mit einer beliebigen Anzahl an Zahlen ermitteln, ohne den Code ändern zu müssen.

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41

startNr = 1 endNr = 10 maxNumberLength = 9 currentLength = 0 currentNr = 0   For currentLength = 2 To maxNumberLength       For currentNr = startNr To endNr             Call NextComb((currentNr), (currentLength - 1), resultString$ + CStr(values(currentNr)))             Next currentNr   Next currentLength     End Function     Public Function NextComb(ByVal begin As Integer, ByVal rest As Integer, resultString As String)   Dim currentNr As Integer, query As String   currentNr = 0   If rest > 0 Then         For currentNr = (begin + 1) To endNr             Call NextComb((currentNr), (rest - 1), resultString$ + " OR APOS=" + CStr(values(currentNr)))         Next currentNr     Else       Debug.Print resultString$     End If   End Function

Hallo Roman,
so richtig funktioniert die Lösung mit dem‚ Rekursiven Algorithmus’ bei mir noch nicht. Insbesondere kann ich nichts mit der Funktion ‚values’ anfangen (ich arbeite mit VB6).
Zum Vergleich hier meine Programmversion zu dem ‚Verbalen Algorithmus’ den ich oben beschrieben habe:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79

: Dim i As Integer Dim iAnzP As Integer Dim iElement As Integer ' ** zum Beispiel Grundmenge 10 Werte iAnzW = 10 ReDim Preserve Wert(1 To iAnzW) For i = 1 To iAnzV '      Wert(i) = Chr(96 + i)  ' als Buchstaben   Wert(i) = i             ' als Zahl Next i ' und 5 Elemente iElement = 5 : : Call Kombintation(Wert(), iElement) : :     Sub Kombintation(mWert() As Variant, iZN As Integer)   ' Ermittelt die möglichen Kombinationen, aus der Menge 'mWert()',   ' 'iZN' Elementen ohne Wiederholung herauszugreifen."         Dim sTmp As String  ' nur für Test       Dim iTest As Long   ' nur für Test       iTest = 0           ' nur für Test         Dim n As Integer   Dim p As Integer   Dim iUG As Integer                    ' untere Array Grenze der Werte   Dim iOG As Integer                    ' obere Array Grenze der Werte   Dim iZM As Integer                    ' Anzahl Elemente in der Grundmenge (Array)   Dim iPos() As Integer                 ' Positionen an denen sich die Elemente befinden   Dim iZEndPos As Integer                ' Zähler wieviele Positionen die Endstellung erreicht haben   Dim iStart As Integer                 ' Startposition des letzten Element (Schleife)     iUG = LBound(mWert())   iOG = UBound(mWert())   iZM = iOG - iUG + 1     ' ** Anfangspositionen initiieren   ReDim iPos(iZN) As Integer   For n = 1 To iZN     iPos(n) = n   Next n     ' Start Schleife   iZEndPos = 0   Do While iZEndPos < iZN     iStart = iPos(iZN - 1) + 1         ' letzte Position erhöhen     For n = iStart To iZM       iPos(iZN) = n                   ' Werte ausgeben, Test                     sTmp = ""                     For p = 1 To iZN                       sTmp = sTmp & mWert(iPos(p)) & vbTab                     Next p                     iTest = iTest + 1                     Debug.Print String(6 * (iZN - 1), "-") & ", lfd. Nr.: " & iTest     Next n         ' Anzahl Elemente in Endposition feststellen     iZEndPos = 0     For n = 0 To iZN - 1       If iPos(iZN - n) = iZM - n Then         iZEndPos = iZEndPos + 1       End If     Next n         ' Positionen aktualisieren     iPos(iZN - iZEndPos) = iPos(iZN - iZEndPos) + 1     For n = iZN - iZEndPos + 1 To iZN       iPos(n) = iPos(n - 1) + 1     Next n   Loop End Sub

Beachte, dass es evtl. zu einer sehr große Anzahl von Kombinationen kommen kann! Bei der Weiterverarbeitung sind Meldungen wie 'nicht genügend Speicher' oder 'Überlauf' leicht möglich. Also vorher prüfen!

Viel Erfolg
Walter Gutermann

Sorry, habe nicht den ganzen Code geposted. Die Variable values ist ein Array, in dem ich die möglichen Werte abgelegt habe. Hier nochmal der vollständige Code:

Code :

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69

Option Compare Database Dim startNr As Integer, endNr As Integer, maxNumberLength As Integer, resultString As String, values(1 To 10) As Double, rs As New ADODB.Recordset, currentLength As Integer, db As DAO.Database, tabelle As String   Public Function Test()   Dim currentNr As Integer   startNr = 1 endNr = 10 maxNumberLength = 9 resultString$ = "APOS=" Set db = CurrentDb   '<-- Diese Variablen anpassen values(1) = 91442540 values(2) = 91441900 values(3) = 3350000 values(4) = 91449590 values(5) = 91010000 values(6) = 91241900 values(7) = 91249590 values(8) = 3350003 values(9) = 3350050 values(10) = 91361900   tabelle$ = "987" '-->   currentLength = 0 currentNr = 0   For currentLength = 2 To maxNumberLength       For currentNr = startNr To endNr             Call NextComb((currentNr), (currentLength - 1), resultString$ + CStr(values(currentNr)))             Next currentNr   Next currentLength     End Function     Public Function NextComb(ByVal begin As Integer, ByVal rest As Integer, resultString As String)   Dim currentNr As Integer, query As String   currentNr = 0   If rest > 0 Then         For currentNr = (begin + 1) To endNr             Call NextComb((currentNr), (rest - 1), resultString$ + " OR APOS=" + CStr(values(currentNr)))         Next currentNr     Else     query$ = "SELECT Feld2 FROM " + tabelle$ + " WHERE " + resultString$ + " GROUP BY Feld2 HAVING COUNT(APOS) > " + CStr(currentLength - 1)     rs.Open query$, CurrentProject.Connection, adOpenStatic     Debug.Print resultString$ + ";" + CStr(rs.RecordCount)     db.Execute "INSERT INTO Ergebnis VALUES ('" + resultString$ + "', " + CStr(rs.RecordCount) + ")"     rs.Close     End If   End Function