Shopping basket or items most frequently picked together ( large data)

[xxsinghxx]

Hi,

I am looking for vba code that would look data in two columns (Col1 "order" and Col2 "Items") then return items frequently picked together on multiple orders. In a way that shopping basket analysis is that how many time customer shopped similar items. such as.

order items
01 A
01 B
01 C
02 B
02 A
03 A
03 C
04 A
04 B
04 C

SO A.B.C = 2 TIMES , A.B = 3 TIMES , AND A.C = 3 TIMES


In my data the order number len is 7-8 and items len is 6-7. Thank you.

 

[Roderick_E]

sounds like this is more simply accomplished with a pivot table

 

[MickG]

For Data in "A & B" , Results in "D"

Option Explicit
[COLOR="Navy"]Dim[/COLOR] Ray()
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


[COLOR="Navy"]Sub[/COLOR] MG27May11
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, p, N, nRay, w [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant

[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Dic(Dn.Value) = Empty
[COLOR="Navy"]Next[/COLOR] Dn
nRay = Application.Transpose(Dic.Keys)
Dic.RemoveAll

[COLOR="Navy"]For[/COLOR] N = 2 To UBound(nRay)
    vElements = Application.Transpose(nRay)
        ReDim vresult(1 To N)
            Call CombinationsNP(vElements, CInt(N), vresult, lRow, 1, 1)
[COLOR="Navy"]Next[/COLOR] N

[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), Nothing
    [COLOR="Navy"]Next[/COLOR] Dn
   
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant, g [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean
   
[COLOR="Navy"]For[/COLOR] N = 0 To UBound(Ray)
   Sp = Split(Ray(N), ",")
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        fd = True
        [COLOR="Navy"]For[/COLOR] ac = 0 To UBound(Sp)
            [COLOR="Navy"]If[/COLOR] Not Dic(k).exists(Sp(ac)) [COLOR="Navy"]Then[/COLOR]
                fd = False
                [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]Next[/COLOR] ac
   [COLOR="Navy"]If[/COLOR] fd = True [COLOR="Navy"]Then[/COLOR]
        g = g + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
    [COLOR="Navy"]If[/COLOR] Not g = 0 [COLOR="Navy"]Then[/COLOR]
        w = w + 1
        Cells(w, "D") = Ray(N) & " = " & g
        g = 0
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] N
c = 0
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 
[COLOR="Navy"]Sub[/COLOR] CombinationsNP(vElements [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] iElement [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] iIndex [COLOR="Navy"]As[/COLOR] Integer)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]For[/COLOR] i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    [COLOR="Navy"]If[/COLOR] iIndex = p [COLOR="Navy"]Then[/COLOR]
        lRow = lRow + 1
        ReDim Preserve Ray(c)
        Ray(c) = Join(vresult, ",")
        c = c + 1
    [COLOR="Navy"]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[xxsinghxx]

sounds like this is more simply accomplished with a pivot table

I tried but since the data is large pivot table does not bundle commonly picked items and display frequencies.

 

[xxsinghxx]

Thank you for quick reply Mick.

I added the above code in the new module. when I run it then excel stops responding. I have numeric data in column "A" and "B".

Order Items

12345678 1234567

 

[MickG]

I should try it on your the Basic data shown in your thread first.
How many rows have you got.
The code is looking for all the combinations, and it doesn't take long to run out of room !!!!

 

[xxsinghxx]

I should try it on your the Basic data shown in your thread first.
How many rows have you got.
The code is looking for all the combinations, and it doesn't take long to run out of room !!!!

There are approximately 28000 entries.

 

[MickG]

I think unfortunately this is a bit of a non started, when you consider that 20 numbers gives you a possible of 1048575 combinations !!!!!

 

[Ombir]

There are approximately 28000 entries.

I'll have a look if you could share link to download your workbook with some entries (1000+).

 

[xxsinghxx]

Here you go Ombir. Thank you for looking into this.

ExpireBox | basket.xlsx