Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Auflistung aller Kombinationsmöglichkeiten

Gruppe

Liste

Problem

100 Kugeln sind von 1 bis 100 beschriftet. 3 Kugeln werden gezogen. Alle Kombinationsmöglichkeiten werden aufgelistet.

Lösung
Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.

StandardModule: Modul1

Sub CombiTest()
   Dim arr(1 To 100) As Integer
   Dim lAll As Long, lCount As Long
   Dim iCounter As Integer
   Dim iCol As Integer
   Dim iA As Integer, iB As Integer, iC As Integer
   Dim sTxt As String, sPath As String
   Dim bln As Boolean
   Application.ScreenUpdating = False
   bln = Application.DisplayStatusBar
   Application.DisplayStatusBar = True
   sPath = Application.DefaultFilePath & "\"
   lCount = WorksheetFunction.Combin(100, 3)
   For iCounter = 1 To 100
      arr(iCounter) = iCounter
   Next iCounter
   Close
   Open sPath & "\combin.txt" For Output As #1
   For iA = 1 To 98
      For iB = 2 To 99
         For iC = 3 To 100
            lAll = lAll + 1
            If lAll Mod 1000 = 0 Then Application.StatusBar = _
               "Bearbeite Kombination " & Format(lAll, "#,##0") & _
               " von " & Format(lCount, "#,##0") & "..."
            If iA >= iB Then iB = 1 + iA
            If iB >= iC Then iC = iB + 1
            If iCol < 3 Then
               iCol = iCol + 1
               sTxt = sTxt & arr(iA) & " " & arr(iB) & " " & arr(iC) & ","
            Else
               iCol = 1
               Print #1, Left(sTxt, Len(sTxt) - 1)
               sTxt = arr(iA) & " " & arr(iB) & " " & arr(iC) & ","
            End If
         Next
      Next
   Next
   Print #1, sTxt
   Close
   Application.StatusBar = "Lade die Daten..."
      Workbooks.OpenText Filename:=sPath & "combin.txt", _
      Origin:=xlWindows, _
      DataType:=xlDelimited, _
      ConsecutiveDelimiter:=False, _
      Tab:=False, _
      Semicolon:=False, _
      Comma:=True, _
      Space:=False, _
      Other:=False
   Application.StatusBar = False
   Application.DisplayStatusBar = bln
   Application.ScreenUpdating = True
End Sub