Possible combinations of values

Question

I'm trying to adapt the Sub + Function from this thread to my need:

Tim Williams solution.

It works fine since all columns have at least 2 values. I'm after if there is a workaround to make it work even if some of the columns have just one value in it.

In the Sub command I could change to col.Add Application.Transpose(sht.Range(Cells(3, c.Column), Cells(Rows.Count, c.Column).End(xlUp))) and it goes fine.

But the Function is crashing at this line: ReDim pos(1 To numIn) just when processing the column that has just one value in it.

Thaks in advance for any help.

add an `if-else` statement checking whether the numIn is `>= 1` or `on error goto ` and handle the ReDim in there — , Jun 26 '14 at 07:10

PatricK · Answer 1 · 2014-06-27T03:37:58.007

I have a more elegant solution with following assumptions:

The data and write to cells are on the same activesheet
Start combination from a cell you specify and going downward then right
Stops going rightward as soon as the cell of the same row is empty
writes the combination from a cell you specify going downwards

Screenshots after the code (Bug fixed on 1 row only on a data column):

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

enter image description here

Possible combinations of values

1 Answers1