Question

所以最近2天我一直在尝试解决此问题。假设在A列中，我有

A
B
C
D

现在，我希望这4个字母中的3个字母全部组合，每个字母都必须排在第一位。例如，

ABC
ACD
ABD
BAC
BDA
BCA
CAB
CBD
CAD
...
etc

注意：ACB和ABC是相同的，因为第二和第三字母顺序无关紧要，但是每个字母都必须显示在第一位置。所以我只希望'ACB'中的一个和“ ABC”

这个例子是4分中的3分，但我想要10分中的5分。谁能帮我这个忙吗？我找不到任何公式，并尝试编写宏/ VBA，但是没有用。非常感谢您的帮助。

Answer 1

我认为这是两个步骤： 1.从4拿起3个字母 2.组合这3个字母。我的结果如下：美国广播公司 ACB 商业咨询委员会 BCA CBA 出租车 ABD 亚行坏 BDA 数据库管理员轻拍 ACD ADC 计算机辅助设计 CDA DCA 数模转换器 BCD 商业发展中心中央商务区国开行 DCB DBC

Answer 2

解决这个问题真的很有趣，我发现一些算法Here和Here可以获取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

在第一个项目的顺序很重要的情况下获取所有组合，而其余的顺序则无关紧要

2 个答案: