- Эта проблема была действительно забавной, я нашел несколько алгоритмов Здесь и Здесь , которые могут получить комбинации из n элементов, но поворот вашего вопросавсе элементы в позиции 1 были действительно захватывающими.
- Этот саб будет делать то, что вы просили, независимо от того, сколько у вас n-элементов (символов) и для любого r-места, которое вы хотите, до тех пор, пока
r <= n. - Я пытался комментировать то, что я могу объяснить (хотя я оставил некоторые довольно трудные для того, чтобы получить строки, к которым я вернусь позже).
[РЕДАКТИРОВАТЬ]:
Я закончил комментировать возможные хитрые части, и конечный продукт выглядит полным ртом и довольно грязно, но это может помочь кому-то там в будущем, поэтому я собираюсь оставить егокак есть.
Option Base 1
Sub getCombinations()
Dim ws As Worksheet, srcCol As String, desCol As String, places As Integer
Dim lastRow As Integer, elements() As String, elmntsCount As Integer, nCr As Long, cmbnationCount As Long
Set ws = ThisWorkbook.ActiveSheet 'Pick the sheet you're working on
srcCol = "A" 'The column that has all the characters in singles
desCol = "B" 'The column you wish to put the resulted combinations into
lastRow = ws.Cells(ws.Rows.count, srcCol).End(xlUp).Row
ReDim elements(1 To lastRow)
For i = 1 To lastRow
elements(i) = ws.Range(srcCol & i).Value2
Next i
elmntsCount = UBound(elements) - LBound(elements) + 1 'The total number of single elements (characters)
Do
places = InputBox("Enter the number of places (r):" & vbNewLine & "I.E, How many characters you want in each combination?" & vbNewLine & "(Places) must be <= " & elmntsCount, "Define the places", 3)
If (places <= elmntsCount) Then Exit Do
MsgBox "Places (r) must be less than or equal to the total count of characters (n) that are in column (" & srcCol & ")." & vbNewLine & "Please, choose a smaller integer for the (places)."
Loop
'To Calculate the number of combinations: first place takes all the possible elements and the rest of the places can be calculated using nCr
'Where n is (total elements -1) and r is (total places -1).
'So the total number of combinations will be: elmntsCount * nCr. And Excel has a built in function for nCr (COMBIN)
nCr = Application.WorksheetFunction.Combin(elmntsCount - 1, places - 1) 'represents how many combinations are there disregarding the character in the first place
cmbnationCount = elmntsCount * nCr
MsgBox "There are " & cmbnationCount & " combinations." & vbNewLine & "I've put them in column (" & desCol & ")."
ws.Range(desCol & 1 & ":" & desCol & cmbnationCount).ClearContents
Dim comb As String, combCount As Long: combCount = 0
Dim indices() As Integer, add As Integer: add = 0
ReDim indices(1 To places)
For i = 1 To places
indices(i) = i
Next i
Do While (True)
comb = ""
'Write current combination
For j = 1 To places
comb = comb & elements(indices(j))
Next j
combCount = combCount + 1
ws.Range(desCol & combCount).Value2 = comb
'Locate last non-max index
'For different combinations where order doesn't matter, The maximum index each place can have is (elmntsCount - places + i) where i is the index's nth place
'So for 7 characters 4 places, the max index for the last place is 7-4+4 = 7. The one before it has a max of 7-4+3 = 6. So all the max indices are 4,5,6,7 in that order
'But since we want to account for the possibility of some place having an index the same as the 1st place's index -given our special twist of the first place-,
'then the max of each place's index become one less than the original max when the first place's index is greater than or equal to that place's index
'And that's what the abs() part in the condition of the while loop is about:
'When (first place's index) is greater than or equal to (the max index of the tested place) make that place's max index 1 less. Otherwise keep it as the original max
i = places
Do While (indices(i) = elmntsCount - places + i - Abs(indices(1) >= elmntsCount - places + i))
i = i - 1
If i = 1 Then
'All indices after 1st index have maxed out
indices(1) = indices(1) + 1
If indices(1) > elmntsCount Then Exit Sub 'We've reached the end.
indices(2) = 0
i = 2
'We've reached the first index, so increment it and start all over with the second one
Exit Do
End If
Loop
'Increment the current index, and if after the incremention it equals the first index, then add 1 more
indices(i) = indices(i) + 1 + Abs((indices(i) + 1) = indices(1)) 'The absolute value part adds 1 if the index after incremention equals the first index, and adds 0 otherwise
'Increment the following indices
For j = i + 1 To places
If (indices(j - 1) + 1) = indices(1) Then add = 1 'Check if an index after incrementing would equal the first index, and add 1 if so
indices(j) = indices(j - 1) + 1 + add 'Each index is (1+add) more than the index before it
add = 0
Next j
Loop
End Sub