VBA

Question

我有一个包含超过 60,000 行和两列的工作表。一列是 t运行saction id，另一列是 item。我想在订单中找到项目的组合。我从有类似问题的人那里找到了这段 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, 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 崩溃。有没有人可以指导我正确的方向？ this is the worksheet that doesn't work

this is what I get when I run it with the item category which works. 完全一样的数据，一个只是商品类别，一个是商品名称。

Answer 1

您的代码示例对我没有任何作用。它运行，但它实际上根本没有产生任何类型的结果。我快速 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

我从这个link.

中发现

VBA - Write all possible combinations of 4 columns of data

我敢肯定，如果您再进行一些谷歌搜索，您会发现其他的概念几乎可以做同样的事情。

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

VBA - Finding all order combinations and count

excel

analysis