在这个 Experts-Exchange PAQ http://rdsrc.us/qdl6tl中，我研究了一个非常相似的问题来枚举五种不同类别事物的每一种组合。每个类别中的事物数量各不相同。枚举必须考虑在一个类别中没有选择的可能性以及从该类别中提取的任何一个选择。
我把这个问题写成一个五位数的数字，其中数字中每个位置的可能位数是一个变量。
Sub CombinatrixPlus()
'Forms all the combinations of at least two subattributes taken from a selection. _
No more than one subattribute may be taken from any row.
'Uses variable base counting method
Dim i As Long, ii As Long, j As Long, k As Long, lenSep As Long, _
m As Long, mCol As Long, mSheet As Long, mRow As Long, _
N As Long, nBlock As Long, nMax As Long, nWide As Long
Dim v As Variant, vInputs As Variant, vResults As Variant
Dim rg As Range, rgDest As Range
Dim ws As Worksheet
Dim s As String, sep As String
Application.ScreenUpdating = False
sep = ", " 'Separator substring between each subattribute in results
Set ws = Worksheets("Sheet2") 'Put first batch of results in this worksheet
Set rgDest = ws.[A2] 'Put results starting in this cell
mSheet = rgDest.Worksheet.Index
mCol = rgDest.Column
lenSep = Len(sep)
Set rg = Selection 'Cells containing the subattributes
nBlock = 16384 'Maximum number of values in results array
'Clear the previous results
Application.DisplayAlerts = False
For i = Worksheets.Count To ws.Index Step -1
Worksheets(i).Cells.Clear 'Clear the cells
If i > ws.Index Then Worksheets(i).Delete 'Delete the sheet
Next
Application.DisplayAlerts = True
N = rg.Rows.Count
nWide = N 'If results lists subattributes in separate cells
'nWide = 1 'If results lists subattributes as a single string with separators
ReDim v(N, 1 To 2)
vInputs = rg.Value
v(0, 2) = 1
For i = 1 To N
v(i, 1) = Application.CountA(rg.Rows(i))
v(i, 2) = (v(i, 1) + 1) * v(i - 1, 2)
Next
nMax = v(N, 2) - 1
ReDim vResults(1 To nBlock, 1 To nWide)
For i = 1 To nMax
s = ""
m = 0
ii = ii + 1
For j = 1 To N
k = (i Mod v(j, 2)) \ v(j - 1, 2)
If k <> 0 Then
m = m + 1
If nWide > 1 Then vResults(ii, j) = vInputs(j, k)
s = s & sep & vInputs(j, k)
End If
Next
s = Mid$(s, lenSep + 1)
If nWide = 1 Then vResults(ii, 1) = s 'Results in a concatentated string
If m < 2 Then ii = ii - 1
If ii = nBlock Then
Application.StatusBar = "Now posting combination " & i & " of " & nMax
mRow = rgDest.Worksheet.Cells(Rows.Count, mCol).End(xlUp).Row
If rgDest.Worksheet.Cells(mRow, mCol) <> "" Then mRow = mRow + 1
If mRow < rgDest.Row Then mRow = rgDest.Row
If (Rows.Count - mRow) >= nBlock Then
rgDest.Worksheet.Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
Else
mSheet = mSheet + 1
If Worksheets.Count < mSheet Then Worksheets.Add After:=Worksheets(mSheet - 1)
With ActiveSheet
Set rgDest = .Range(rgDest.Address)
For j = 1 To N
.Columns(j).ColumnWidth = ws.Columns(j).ColumnWidth
Next
mRow = rgDest.Row
.Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
End With
End If
ii = 0
ReDim vResults(1 To nBlock, 1 To nWide)
End If
Next
If ii > 0 Then
Application.StatusBar = "Now posting combination " & i & " of " & nMax
mRow = rgDest.Worksheet.Cells(Rows.Count, mCol).End(xlUp).Row
If rgDest.Worksheet.Cells(mRow, mCol) <> "" Then mRow = mRow + 1
If mRow < rgDest.Row Then mRow = rgDest.Row
If (Rows.Count - mRow) >= nBlock Then
rgDest.Worksheet.Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
Else
mSheet = mSheet + 1
If Worksheets.Count < mSheet Then Worksheets.Add After:=Worksheets(mSheet - 1)
With ActiveSheet
Set rgDest = .Range(rgDest.Address)
For j = 1 To N
.Columns(i).ColumnWidth = ws.Columns(j).ColumnWidth
Next
mRow = rgDest.Row
.Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
End With
End If
i = rgDest.Worksheet.UsedRange.Rows.Count 'Reset the scrollbar
End If
Application.StatusBar = False 'Clear the status bar
Application.ScreenUpdating = True
End Sub
