VBA - Finding all order combinations and count - excel

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.