Question

Aisle 1 Aisle 2 Aisle 3 Aisle 4 Aisle 5 Aisle 6 Aisle 7 Aisle 8 Aisle 9 Aisle 10
Apple   Apple   Towels  Soap    Cans    Cans    Forks   Shampoo Toys    Chips
Orange  Tomato  Boxes   Clean   Bottles Cups    Knives  B Wash  Games   Snacks
Pear    Potato          Plates  Spoons          Candy
Pina

上面列出的是我需要拥有所有可能组合的列。

这是我现在拥有的宏：

Sub Aisles()
 Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long

Set sht = ActiveSheet
For Each c In sht.Range("A4:J4").Cells
    col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
    numCols = numCols + 1
Next c

res = Combine(col, "~~")

For i = 0 To UBound(res)
    arr = Split(res(i), "~~")
    sht.Range("L3").Offset(i, 0).Resize(1, numCols) = arr
Next i

End Sub



Function Combine(col As Collection, SEP As String) As String()

Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long

numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
    lbs(i) = LBound(col(i))
    ubs(i) = UBound(col(i))
    lengths(i) = (ubs(i) - lbs(i)) + 1
    pos(i) = lbs(i)
    t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array

For n = 0 To (t - 1)
    s = ""
    For i = 1 To numIn
        s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
    Next i
    rv(n) = s

    For i = numIn To 1 Step -1
        If pos(i) <> ubs(i) Then   'Not done all of this array yet...
            pos(i) = pos(i) + 1    'Increment array index
            For r = i + 1 To numIn 'Reset all the indexes
                pos(r) = lbs(r)    '   of the later arrays
            Next r
            Exit For
        End If
    Next i
Next n

Combine = rv
End Function

我需要帮助的有两件事：

我只需要允许列中列出的1个项目。实际上，宏需要在列中列出至少2个项目才能工作。
一旦选择了项目，我需要宏来排除项目：例如，在第1列中列出“apple”，也列在第2列中。第5列和第6列中也是“cans”。苹果不能存放在2个不同的过道中。我想这可能被称为排列？因此，最终的组合列表没有任何重复项。

Answer 1

没有欺骗并且切换到2-d阵列作为返回类型，这更加清晰。

Sub Aisles()

    Dim col As New Collection
    Dim c As Range, sht As Worksheet, res
    Dim i As Long, arr, numCols As Long
    Dim rng As Range

    Set sht = ActiveSheet

    For Each c In sht.Range("A4:J4").Cells

        Set rng = sht.Range(c, sht.Cells(Rows.Count, c.Column).End(xlUp))

        If rng.CountLarge > 1 Then
            col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
        Else
            'deal with case where there's only a single value in the column
            col.Add Array(c.Value)
        End If

        numCols = numCols + 1
    Next c

    res = CombineNoDups(col)

    sht.Range("L3").Offset(i, 0).Resize(UBound(res, 1), _
                                        UBound(res, 2)).Value = res

End Sub


Function CombineNoDups(col As Collection)

    Dim rv(), tmp()
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long, x As Long
    Dim numIn As Long, s As String, r As Long, v, dup As Boolean

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)

    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i

    ReDim rv(1 To t, 1 To numIn) 'resize destination array
    x = 0

    For n = 1 To t

        ReDim tmp(1 To numIn)
        dup = False
        For i = 1 To numIn
            v = col(i)(pos(i))
            If Not IsError(Application.Match(v, tmp, 0)) Then
                dup = True
                Exit For
            Else
                tmp(i) = v
            End If
        Next i

        If Not dup Then
            x = x + 1
            For i = 1 To numIn
                rv(x, i) = tmp(i)
            Next i
        End If

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    CombineNoDups = rv
End Function

创建最多X列的所有组合的列表，无重复

1 个答案: