VBA-查找所有订单组合和数量 [英] VBA - Finding all order combinations and count

问题描述

我有一个包含超过60,000行和两列的工作表.一栏为交易编号，另一栏为项目.我想找到订单中的物品组合.我从有类似问题的人那里找到了这个vba代码

I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem

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, ps(1, j), ps(2, 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, ps(1, i), ps(2, i))
          For j = i + k To ic
            
            entry = entry & Mid(Item, ps(1, j), ps(2, 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
End Sub

当我运行完全相同的代码但带有项目类别时，哪个工作了.问题是我正在使用项目名称运行它，并且它总是使Excel崩溃.有没有人可以指导我正确的方向? 这是无效的工作表

Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction? this is the worksheet that doesn't work

这是在使用有效的项目类别运行它时得到的. 它们是完全相同的数据，一个只是项目类别，另一个是项目名称.

this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.

推荐答案

您的代码示例对我没有任何帮助.它运行了，但实际上根本没有产生任何结果.我在Google上进行了快速搜索，发现了这一点.

Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.

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-编写4列的所有可能组合数据

我敢肯定，如果您再进行一次Google搜索，您会发现其他具有相同功能的概念.

I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.

这篇关于VBA-查找所有订单组合和数量的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！