Hallo,
Als we dit als een oefening beschouwen ... (want ik zie niet goed in, wat je me deze lijst kan doen)
Ik heb wel een oplossing, maar die zal naar schatting een uur - of toch zeker een half uur - draaien op mijn PC. Het komt er op neer dat er een matrix met strings aangemaakt en weggeschreven wordt per kolom. De traagheid berust naar alle waarschijnlijkheid op het werken met strings, maar 't is toch een goed begin, denk ik.
Option Explicit
Dim i As Long
Dim j As Long
Dim rc As Long
Dim ItemsCount As Long
Dim arr() As Variant
Sub Combinations()
Dim n As Integer
Dim m As Integer
Dim test As Boolean
rc = Rows.Count
ReDim arr(1 To rc)
i = 0
j = 0
n = InputBox("Number of items?", "Combinations")
m = InputBox("Taken how many at a time?", "Combinations")
With Application
ItemsCount = .WorksheetFunction.Combin(n, m)
.StatusBar = ItemsCount & " combinations to generate ... calculating ..."
.ScreenUpdating = False
Comb2 n, m, 1, ""
On Error Resume Next
test = UBound(arr) > 0
On Error GoTo 0
If test Then
Columns(j + 1).ClearContents
Cells(1, j + 1).Resize(UBound(arr)) = .Transpose(arr)
End If
.StatusBar = False
.ScreenUpdating = True
End With
End Sub
'Generate combinations of integers k..n taken m at a time, recursively
'Original codeidea by Myrna Larson
'https://www.mydatabasesupport.com/forums/spreadsheets/250561-combinations.html
Private Function Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String)
If m > n - k + 1 Then Exit Function
If m = 0 Then
i = i + 1
arr(i) = s
If i = rc Then
i = 0
j = j + 1
Columns(j).ClearContents
With Application
Cells(1, j).Resize(rc) = .Transpose(arr)
.StatusBar = Format(j * rc / ItemsCount, "000 %")
End With
Erase arr
ReDim arr(1 To rc)
End If
Exit Function
End If
Comb2 n, m - 1, k + 1, s & k & " "
Comb2 n, m, k + 1, s
End FunctionAls Diesel zijn 18seconden oplossing terugvindt, staan we heel wat verder.
beste groeten,
Erik
