Excel VBA宏生成可能的組合列表

Question

我正在嘗試編寫一個Excel宏來生成可能組合的列表。

我在不同的列中有一系列固定的值

A，B，C，D-每個都在自己的列中。

我有一個新值列表，可替換為A，B，C或D，並希望生成所有組合。

新值列表，即1、2、3、4

我總共會得到16種不同的組合

例如，

1BCD
2BCD
3BCD
4BCD
A1CD
A2CD
A3CD

...
ABC1
ABC2
ABC3
ABC4

我不確定是否很清楚，但是我想通過遍歷每一列以生成可能的組合並插入新的值來生成組合。

Answer 1

您可以使用以下內容交叉連接兩個不同的范圍。 它將處理任何大小的范圍，並將交叉連接的組合寫入指定的目標工作表。

在下面的示例中，我定義了兩個命名范圍： newValues和fixedValues 。 這兩個范圍都在Sheet1 。 然后，我遍歷范圍並將所有組合寫入Sheet2 。

Sub CrossJoinMyRanges()
    Dim ws As Worksheet
    Dim newValues As Range
    Dim cell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set newValues = ws.Range("newValues")

    ' loop through the new values
    For Each cell In newValues
        Call ReplaceMe(cell.Value, ws)
    Next cell
End Sub

Sub ReplaceMe(replacement As String, ws As Worksheet)
    Dim fixedValues As Range
    Dim cell As Range

    Set fixedValues = ws.Range("fixedValues")

    ' outer loop through fixedValues
    For Each cell In fixedValues
        Call PrintReplacedValues(cell.Row, replacement)
    Next cell
End Sub

Sub PrintReplacedValues(rowNumber As Long, replacement As String)
    Dim wb As Workbook
    Dim src As Worksheet
    Dim tgt As Worksheet
    Dim fixedValues As Range
    Dim cell As Range
    Dim printMe As String
    Dim x As Long, y As Long

    Set wb = ThisWorkbook
    Set src = wb.Sheets("Sheet1")
    Set tgt = wb.Sheets("Sheet2")
    Set fixedValues = src.Range("fixedValues")
    y = 1
    x = tgt.Range("A" & tgt.Rows.Count).End(xlUp).Row + 1

    ' inner loop through fixed values
    For Each cell In fixedValues
        ' replace the fixed value with the replacement
        ' if the loops intersect
        If cell.Row = rowNumber Then
            printMe = replacement
        Else
        ' otherwise keep the fixed value
            printMe = cell
        End If
        ' write to the target sheet
        tgt.Cells(x, y).Value = printMe
        y = y + 1
    Next cell
End Sub

如果我的方法不符合您的要求，您還可以通過替代解決方案找到一些類似的問題：

Excel vba創建范圍的所有可能組合

如何獲取Excel中的列等笛卡爾積？