VBA-查找所有订单组合和数量

如何解决VBA-查找所有订单组合和数量

我有一个包含超过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

我敢肯定，如果您再进行谷歌搜索，您会发现其他具有相同功能的概念。