可能的值组合答案

【问题标题】：Possible combinations of values可能的值组合
【发布时间】：2014-06-25 22:29:48
【问题描述】：

我正在尝试使该线程中的 Sub + Function 适应我的需要：

蒂姆·威廉姆斯解决方案。

它工作正常，因为所有列都至少有 2 个值。即使某些列中只有一个值，我也会关注是否有解决方法使其工作。

在 Sub 命令中，我可以更改为 col.Add Application.Transpose(sht.Range(Cells(3, c.Column), Cells(Rows.Count, c.Column).End(xlUp))) 一切顺利。

但是函数在这一行崩溃了： ReDim pos(1 To numIn) 仅在处理其中只有一个值的列时。

提前谢谢您的帮助。

【问题讨论】：

添加一个if-else 语句检查numIn 是>= 1 还是on error goto <label> 并在那里处理ReDim

标签： vba

【解决方案1】：

我有一个更优雅的解决方案，假设如下：

数据和写入单元格在同一个活动表上
从您指定的单元格开始组合，然后向下然后向右
一旦同一行的单元格为空，就停止向右移动
从您指定的单元格向下写入组合

代码后的屏幕截图（仅在数据列的 1 行上修复了错误）：

Private Const sSEP = "|" ' Separator Character

Sub ListCombinations()
    Dim oRngTopLeft As Range, oRngWriteTo As Range

    Set oRngWriteTo = Range("E1")
    Set oRngTopLeft = Range("A1")

    WriteCombinations oRngWriteTo, oRngTopLeft

    Set oRngWriteTo = Nothing
    Set oRngTopLeft = Nothing

End Sub

Private Sub WriteCombinations(ByRef oRngWriteTo As Range, ByRef oRngTop As Range, Optional sPrefix As String)
    Dim iR As Long ' Row Offset
    Dim lLastRow As Long ' Last Row of the same column
    Dim sTmp As String ' Temp string

    If IsEmpty(oRngTop) Then Exit Sub ' Quit if input cell is Empty
    lLastRow = Cells(Rows.Count, oRngTop.Column).End(xlUp).Row
    'lLastRow = oRngTop.End(xlDown).Row ' <- Bug when 1 row only
    For iR = 0 To lLastRow - 1
        sTmp = ""
        If sPrefix <> "" Then
            sTmp = sPrefix & sSEP & oRngTop.Offset(iR, 0).Value
        Else
            sTmp = oRngTop.Offset(iR, 0).Value
        End If
        ' No recurse if next column starts empty
        If IsEmpty(oRngTop.Offset(0, 1)) Then
            oRngWriteTo.Value = sTmp ' Write value
            Set oRngWriteTo = oRngWriteTo.Offset(1, 0) ' move to next writing cell
        Else
            WriteCombinations oRngWriteTo, oRngTop.Offset(0, 1), sTmp
        End If
    Next
End Sub

【讨论】：