VBA - Finding all order combinations and count

Question

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

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.

Answer 1

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

I found that from this link.

VBA - Write all possible combinations of 4 columns of data

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