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

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 

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

这是我现在的macros：

 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. 我只需要允许列中列出一个项目。 实际上，macros需要至less2个项目列在列中才能工作。

2. 我需要macros来排除一个项目，例如在列1中列出了“苹果”，也列在列2中。同样，列5和列6中也是“jar子”。苹果不能存储在2个不同的过道中。 我想这可能被称为排列？ 所以组合的最终列表没有任何重复的项目。

Answer 1

没有笨拙，并切换到一个二维数组作为返回types，这是更清洁。

 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