在 Excel VBA 中创建组合

Posted 2023-03-31

【中文标题】在 Excel VBA 中创建组合

【英文标题】：Create combinations in Excel VBA

【发布时间】：2013-05-25 01:56:24

【问题描述】：

我搜索了整个网站，试图寻找一个宏（或函数），它可以从相邻列中的给定列表创建独特的组合。

所以基本上，我有：

A  1  F1  R1  
B  2  F2  
C     F3  
D  
E  

我正在尝试将所有信息列为（在同一个工作表和不同列中）：

A 1 F1 R1  
A 1 F2 R1  
A 1 F3 R1  
A 2 F1 R1  
A 2 F2 R1  
A 2 F3 R1  
B 1 F1 R1  
B 1 F2 R1  
B 1 F3 R1  
B 2 F1 R1  
B 2 F2 R1  
B 2 F3 R1  
...etc.

（能够切换列表在工作表上的打印位置的额外奖励）

【问题讨论】：

不清楚您所说的“唯一组合”是什么意思，因为您的示例似乎无法正常工作，因为您缺少很多值并且在行之间混合项目。

你到底有什么？您是否在此列表中包含单元名称？

一组中是否总是正好有 4 个项目？集合可以重复吗？换句话说，A-A-F1-F1 是有效成员吗？ A-B-C 是有效会员吗？您需要更具体地了解构成有效集合的内容。

抱歉，我不知道为什么我发帖时格式乱了。我的意思是 A、B、C、D、E 都在 A 列中。1、2 在 B 列中。F1-3 在 C 列中。而 R1 在 D 列中。我正在尝试创建尽可能多的组合我可以从数据中。此外，该集合不能具有来自同一列的值，它必须使用来自不同列的值并且集合中恰好有四个项目@TylerDurden

【参考方案1】：

https://app.box.com/s/47b28f19d794b25511be 有一本工作簿，其中包含基于公式和基于 VBA 的方法。

【讨论】：

我没有意识到这是一个两年前的帖子，对不起。

【参考方案2】：

获取所有可能组合的代码如下

Option Explicit

Sub Combinations()

    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")
    Dim a As Range, b As Range, c As Range, d As Range
    Dim x&, y&, z&, w&

    For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
        Set a = ws.Range("A" & x)
        For y = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row
            Set b = ws.Range("B" & y)
            For z = 1 To ws.Range("C" & Rows.Count).End(xlUp).Row
                Set c = Range("C" & z)
                For w = 1 To ws.Range("D" & Rows.Count).End(xlUp).Row
                    Set d = ws.Range("D" & w)
                    Debug.Print a & vbTab & b & vbTab & c & vbTab & d
                    Set d = Nothing
                Next
                Set c = Nothing
            Next
            Set b = Nothing
        Next y
        Set a = Nothing
    Next x

End Sub

和输出

A   1   F1  R1
A   1   F2  R1
A   1   F3  R1
A   2   F1  R1
A   2   F2  R1
A   2   F3  R1
B   1   F1  R1
B   1   F2  R1
B   1   F3  R1
B   2   F1  R1
B   2   F2  R1
B   2   F3  R1
C   1   F1  R1
C   1   F2  R1
C   1   F3  R1
C   2   F1  R1
C   2   F2  R1
C   2   F3  R1
D   1   F1  R1
D   1   F2  R1
D   1   F3  R1
D   2   F1  R1
D   2   F2  R1
D   2   F3  R1
E   1   F1  R1
E   1   F2  R1
E   1   F3  R1
E   2   F1  R1
E   2   F2  R1
E   2   F3  R1

【讨论】：

嗨@mehow 我运行了宏，但是它没有将任何结果输出到工作表中

@user2425910 它没有被告知这样做:) 如果您在运行代码之前/之后单击CTRL + G，您将在VBE 视图中打开一个名为Immediate Window 的窗口，这是一个VBA 的调试控制台，您的输出将在那里。您可以修改Debug.Print 以输出到工作表

【参考方案3】：

试试这个 VBA 代码：

Type tArray
    value As String
    count As Long
End Type

Sub combineAll()
    Dim sResult(10) As tArray, rRow(10) As Long, str() As String
    Dim sRow As Long, sCol As Long
    Dim i As Long, r As Long
    Dim resRows As Long
    sRow = 1: sCol = 1: r = 0

    With ActiveSheet
        Do
            rRow(sCol) = 1
            If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
            Do
                If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
                sResult(sCol).value = sResult(sCol).value & Trim(.Cells(sRow, sCol).value) & ";"
                sResult(sCol).count = sResult(sCol).count + 1
                sRow = sRow + 1
            Loop
            sCol = sCol + 1
            sRow = 1
        Loop

        Do
            r = r + 1
            For i = 1 To sCol - 1
                str = Split(sResult(i).value, ";")
                .Cells(r, sCol + i).value = str(rRow(i) - 1)
            Next i

            For i = sCol - 1 To 1 Step -1
                If rRow(i) < sResult(i).count Then
                    rRow(i) = rRow(i) + 1
                    Exit For
                Else
                    rRow(i) = 1
                End If
            Next i

            If rRow(1) >= sResult(1).count Then Exit Do
        Loop

    End With

End Sub