跳到主要内容

如何从 Excel 的单列中列出所有可能的组合？

如果您想从单列数据中返回所有可能的组合以获得如下屏幕截图所示的结果，您是否有任何快速的方法可以在 Excel 中处理此任务？

用公式列出单列中所有可能的组合

使用 VBA 代码列出单列中所有可能的组合

用公式列出单列中所有可能的组合

以下数组公式可以帮助您完成这项工作，请逐步执行：

1. 首先，您应该创建两个辅助公式单元格。 在 C1 单元格中，请输入以下公式，然后按 Ctrl + Shift + Enter 获得结果的关键：

=MAX(LEN(A2:A6))
备注：在此公式中， A2：A6 是您要列出其组合的单元格列表。

2. 在单元格 C2 中，输入以下公式，然后按 Ctrl + Shift + Enter 键一起得到第二个结果，见截图：

=CONCAT(A2:A6&REPT(" ",C2-LEN(A2:A6)))
备注：在此公式中， A2：A6 是您要列出其组合的单元格列表， C2 单元格是否包含您在步骤 1 中创建的公式。

3. 然后，将以下公式复制并粘贴到单元格 D2 中，然后按 Ctrl + Shift + Enter 键在一起以获得第一个结果，请参见屏幕截图：

=IF(ROW()>2^(COUNTA(A$2:A$6)),"",TEXTJOIN(" + ",TRUE,IF(MID(TEXT(DEC2BIN(ROW()-1),REPT("0",COUNTA($A$2:$A$6))),ROW(INDIRECT("1:"&COUNTA($A$2:$A$6))),1)+0,TRIM(MID($C$3,(ROW(INDIRECT("1:"&COUNTA($A$2:$A$6)))-1)*$C$2+1,$C$2)),"")))
备注：在此公式中， A2：A6 是您要列出其组合的单元格列表， C2 单元格是否包含您在步骤 1 中创建的公式， C3 是具有您在步骤 2 中创建的公式的单元格， + 字符是分隔组合的分隔符，您可以根据需要更改它们。

4. 然后，选择此公式单元格，然后向下拖动填充柄，直到出现空白单元格。 现在，您可以看到指定列数据的所有组合显示如下演示所示：

备注：此公式仅适用于 Office 2019、365 及更高版本。

使用 VBA 代码列出单列中所有可能的组合

以上公式仅适用于较新的 Excel 版本，如果您有较早的 Excel 版本，以下 VBA 代码可以帮到您。

1。 按 Alt + F11 同时打开 Microsoft Visual Basic应用程序 窗口。

2。 然后，点击 插页 > 模块，将以下 VBA 代码复制并粘贴到窗口中。

VBA 代码：列出单列中所有可能的组合

Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
xDValue = Range("A2:A6").Value 'the data range
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub
备注：在上面的代码中：
  • A2：A6: 是您要使用的数据列表；
  • C1: 是输出单元格；
  • ,: 分隔组合的分隔符。

3. 然后，按 F5 执行此代码的关键。 单列中的所有组合如下图所示：

最佳办公生产力工具

🤖 Kutools 人工智能助手：基于以下内容彻底改变数据分析： 智能执行   |  生成代码  |  创建自定义公式  |  分析数据并生成图表  |  调用 Kutools 函数...
热门特色: 查找、突出显示或识别重复项   |  删除空白行   |  合并列或单元格而不丢失数据   |   不使用公式进行四舍五入 ...
超级查询: 多条件VLookup  |   多值VLookup  |   跨多个工作表的 VLookup   |   模糊查询 ....
高级下拉列表: 快速创建下拉列表   |  依赖下拉列表   |  多选下拉列表 ....
列管理器: 添加特定数量的列  |  移动列  |  切换隐藏列的可见性状态  |  比较范围和列 ...
特色功能: 网格焦点   |  设计图   |   大方程式酒吧   |  工作簿和工作表管理器   |  资源库 （自动文本）   |  日期选择器   |  合并工作表   |  加密/解密单元格   |  按列表发送电子邮件   |  超级筛选   |   特殊过滤器 （过滤粗体/斜体/删除线...）...
前 15 个工具集:  12 文本 工具 (添加文本, 删除字符，...）   |   50+ 图表 类型 (甘特图，...）   |   40+ 实用 公式 (根据生日计算年龄，...）   |   19 插入 工具 (插入二维码, 从路径插入图片，...）   |   12 转化 工具 (小写金额转大写, 货币兑换，...）   |   7 合并与拆分 工具 (高级组合行, 分裂细胞，...）   |   ... 和更多

使用 Kutools for Excel 增强您的 Excel 技能，体验前所未有的效率。 Kutools for Excel 提供了 300 多种高级功能来提高生产力并节省时间。  单击此处获取您最需要的功能...

产品描述

Office Tab 为 Office 带来选项卡式界面，让您的工作更加轻松

  • 在Word，Excel，PowerPoint中启用选项卡式编辑和阅读，发布者，Access，Visio和Project。
  • 在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。
  • 每天将您的工作效率提高50％，并减少数百次鼠标单击！
Comments (11)
No ratings yet. Be the first to rate!
S Shekhar
S Shekhar
This comment was minimized by the moderator on the site
Hi Skyyang,

Not sure if you are still active on this thread. But just taking a chance in case. I am not very familiar with VBA coding and am stuck in a situation where I need code to tackle one situation in my project. I need to create a unique combination from the list of variables mentioned in "SHEET1" cells "A2:A20". The combination will be of 2 variables listed in the row starting from A2 in SHEET2. And a list with 3 variable combinations listed in the row starting from A2 in SHEET3.

Thanks in advance.
Reply
0
0
iulker
iulker
This comment was minimized by the moderator on the site
Hello,
Nice job!
But I'm interested to find just the "Sets of 2", as in your example, e.g. a list of players who have to play matches with each other :).
Thank you.
Reply
Report
0
0
skyyang
skyyang     iulker
This comment was minimized by the moderator on the site
Hello, Iulian,
To solve your problem, please apply the below code:
Note: your names should be start at A2 cell, and the result will be placed at C2 cell.
Sub name_by_name()
    Dim i As Long, j As Long, lr As Long
    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            For j = i + 1 To lr
                .Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = _
                  .Cells(i, 1).Value & ", " & .Cells(j, 1).Value
            Next j
        Next i
    End With
End Sub


Please have a try, hope it can help you!

https://www.extendoffice.com/images/stories/comments/comment-skyyang/2023-comment/combinations-1.png
Reply
Report
0
0
Lynn
Lynn
This comment was minimized by the moderator on the site
Hello, I have a list of 30 items in a column and the code doesn't seem to be able to handle that, what is the max number of items allowed for the code to work? is there a way to make a long list work?
Reply
0
0
skyyang
skyyang     Lynn
This comment was minimized by the moderator on the site
Hello, Lynn,
Yes, as you said, if the number of cells are greater than 20, the code will not work well.
Sorry for that inconvenience.

With this code, it will pop out an alert if the number of cells is greater than 20.
Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
Dim xAddress As String
xAddress = "A1:A20" 'the data range
If Range(xAddress).Count > 20 Then
    MsgBox "The number of cells can't greater than 20!"
    Exit Sub
End If
xDValue = Range(xAddress).Value
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub
Reply
Report
0
0
ffuuzz
ffuuzz
This comment was minimized by the moderator on the site
I really like the method but values bottom out at the 511th row and you get #NUM! if you have more than 6 entries in column A. I'm wondering if someone might consider helping me to adjust the formula so that the resulting values calculate beyond the 511th row? Thank you very much! =)
Reply
0
0
skyyang
skyyang     ffuuzz
This comment was minimized by the moderator on the site
Hello,
Yes, as you said, the formula will stop work in row 511. So, here, you can appy the VBA code in this article.
Or if you want to list all possible combinations into single one column, please apply the below code:
Note: In the code, A2 is the first cell contains the data you want to use, you should change the cell reference A2 and A to your own. After running the code, all combinations will be listed in the next column of the data list.
Sub allcombination()
Dim Ray As Variant, n As Long, nn As Long, Allnum As String, c As Long
Dim Res As Long, obit, oSt, ipc, Tot As Long, oPst As Long, sNum As String
Ray = Application.Transpose(Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)))
sNum = Join(Evaluate("TRANSPOSE(ROW(" & 1 & ":" & UBound(Ray) & "))"), ",")
For n = 1 To UBound(Ray)
    Tot = Tot + Application.Combin(UBound(Ray), n)
Next n
ReDim Oval(1 To Tot)
ReDim nRay(1 To Tot - UBound(Ray))
Do Until Allnum = sNum
   If c < UBound(Ray) Then
       For n = 1 To UBound(Ray)
             c = c + 1: Oval(c) = n
       Next n
   Else
       For n = 1 To UBound(Ray)
             Res = Res + 1
             obit = Oval(Res)
             oSt = Split(obit, ",")(UBound(Split(obit, ",")))
                For nn = oSt + 1 To UBound(Ray)
                    c = c + 1
                    Allnum = obit & "," & nn
                    Oval(c) = Allnum
                Next nn
         Next n
   End If
Loop
Dim s As Variant, nStr As String
    For oPst = UBound(Ray) + 1 To UBound(Oval)
        For Each s In Split(Oval(oPst), ",")
            nStr = nStr & IIf(nStr = "", Ray(s), "," & Ray(s))
        Next s
            nRay(oPst - UBound(Ray)) = nStr: nStr = ""
  Next oPst
Range("B1").Resize(UBound(nRay)).Value = Application.Transpose(nRay)
End Sub

Please have a try, hope it can help you! 🙂
Reply
Report
0
0
ffuuzz
ffuuzz     skyyang
This comment was minimized by the moderator on the site
Dear skyyang:

Thank you very much for your help and the code. It's invaluable and I'm grateful.

I'm relatively new to VB scripting, consequently not very adept at coding the language.

Just a point or two:

- Your suggested code doesn't generate single entries (e.g. Ruby, or...)
- The original ordering as highlighted in the animated graphic in Step 4 disappeared.

I will go through your code to try my hand at calibrating it so that the above points are outputted, but I was wondering if you had any quick advice or suggestion(s) that could address them.

Thank you again for your kind help. I really appreciate it. =)

My best.
Reply
Report
0
0
ffuuzz
ffuuzz     skyyang
This comment was minimized by the moderator on the site
Dear skyyang:

First, thank you very much for your code solution. I am grateful! =)

I wrote a reply yesterday but the system seems not to have posted it for unknown reasons. I hope this one gets through.

Your code generates output that I am interested in. I had just a couple of observations and then a question:

1) The code doesn't generate the individual entries alone.
2) The original ordering seen in the animated graphic in Step 4 is lost.

From your code is there a way to also include the single entries and to mirror the original ordering format from Step 4. I'm rather new to VB scripting.

Again, thank you so much for your invaluable help. I really appreciate it.

My best.
Reply
0
0
ffuuzz
ffuuzz     skyyang
This comment was minimized by the moderator on the site
Dear skyyang:

This is wonderful. Thank you, this helps me out immensely. I am very grateful.

Just a couple observations I noticed after generating the VB code you provided was that the singletons (for lack of a better term), like just "Ruby", would get omitted, and the resulting (columnal) ordering no longer corresponded to the original ordering generated in Step 4 animated graphic.

Do you happen to have any quick suggestions about how I could tweak your code to also include the "singletons" and for matching the same ordering as in Step 4? I will try to wrangle the workaround but regrettably I'm fairly new to VB scripting.

Thanks again! I really appreciate it.

My best. =)
Reply
0
0
skyyang
skyyang     ffuuzz
This comment was minimized by the moderator on the site
Hello, ffuuzz
In this case, you can try the vba code in our article, all possible combinations will be listed into separated columns, please try:
Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
xDValue = Range("A2:A6").Value 'the data range
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub
Reply
Report
0
0
There are no comments posted here yet
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations