问题描述
我有一个包含超过60,000行和两列的工作表。一栏为交易编号，另一栏为项目。我想在订单中找到物品的组合。我从有类似问题的人那里找到了这个vba代码
Sub basket()
On Error Resume Next
Dim ps(2,20)
r = 3
tr = Cells(2,1)
Item = Cells(2,2) + "."
ps(1,1) = 1
ps(2,1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r,1) <> ""
If Cells(r,1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item,ps(1,i),ps(2,i))
For j = i + k To ic
entry = entry & Mid(Item,j),j))
Cells(r2,10) = tr
Cells(r2,11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry,Range("e:e"),0)
If x = 0 Then
x = r3
Cells(x,5) = entry
r3 = r3 + 1
End If
Cells(x,6) = Cells(x,6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r,1)
End If
ps(1,ic) = Len(Item) + 1
ps(2,ic) = Len(Cells(r,2)) + 1
Item = Item + Cells(r,2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item,6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
当我运行完全相同的代码但带有项目类别时，哪个工作了。问题是我正在使用项目名称运行它，并且它总是使Excel崩溃。有没有人可以指导我正确的方向？ this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. 它们是完全相同的数据，一个只是作为项目类别，另一个是项目名称。
解决方法
您的代码示例对我没有任何帮助。它运行了，但实际上根本没有产生任何结果。我做了一个快速的Google搜索，发现了这个。
Sub ListCombinations()
Dim col As New Collection
Dim c As Range,sht As Worksheet,res
Dim i As Long,arr,numCols As Long
Set sht = ActiveSheet
'lists begin in A1,B1,C1,D1
For Each c In sht.Range("A2:B2").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("H1").Offset(i,0).Resize(1,numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
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
我从此链接中找到了。
VBA - Write all possible combinations of 4 columns of data
我敢肯定，如果您再进行谷歌搜索，您会发现其他具有相同功能的概念。