Algorithmus für Kombinationen

[Roman Locher]

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.

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

 

[WaGutSo]

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:

:
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

 

[Roman Locher]

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:

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