Using VBA to Return Multiple Matches and Aggregate Responses on Different Cells

[lisaodo87]

Hope you are well,

I have a large data base and I need the below in excel using VBA preferably or a formula. AT moment data is below.

I have multiple company names that have chosen a huge amount of products. I have the listing name in one cell and listing ID in another cell and the products chosen but need to list all products and the listing names (companies) along with their listing IDs who have chosen this product. (in reverse way).

At the moment.

Cell 1 Cell 2 Cell 2 Cell 4 Cell 6 Cell 7 (so forth)
Listing Name Listing ID Product Product Product
Listing Name Listing ID Product Product Product
Listing Name Listing ID Product Product Product

Needs to be

Product
Listing Name Listing ID
Listing Name Listing ID
Listing Name Listing ID
Product 2
Listing Name Listing ID
Listing Name Listing ID
Listing Name Listing ID

And so fourth, there is over 1000 unique products and over 900 listing names/companies.

Kind Regards,
Lisa

 

[MickG]

Try this:-
Data on sheet1 , start row 2.
Results sheet2

[COLOR="Navy"]Sub[/COLOR] MG08May39
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object, nRay()
Ray = Sheets("Sheet1").Range("A1").CurrentRegion
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
        [COLOR="Navy"]For[/COLOR] Ac = 3 To UBound(Ray, 2)
          [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
               ReDim nRay(1 To 2, 1 To 1)
                nRay(1, 1) = Ray(n, 1): nRay(2, 1) = Ray(n, 2)
                Dic.Add Ray(n, Ac), nRay
            [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Ray(n, Ac))
                  ReDim Preserve Q(1 To 2, 1 To UBound(Q, 1) + 1)
                   Q(1, UBound(Q, 1)) = Ray(n, 1)
                   Q(2, UBound(Q, 1)) = Ray(n, 2)
               Dic(Ray(n, Ac)) = Q
            [COLOR="Navy"]End[/COLOR] If
          [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Ac
 [COLOR="Navy"]Next[/COLOR] n

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ReDim rray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    c = c + 1: rray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Dic(K), 2)
        c = c + 1
        rray(c, 1) = Dic(K)(1, n)
        rray(c, 2) = Dic(K)(2, n)
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 2)
    .Value = rray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MickG]

NB:-There is an error in the code, please replace the part shown in red below in your code.

                    Q = Dic(Ray(n, Ac))
                 [COLOR="#FF0000"][B] ReDim Preserve Q(1 To 2, 1 To UBound(Q, 2) + 1)
                   Q(1, UBound(Q, 2)) = Ray(n, 1)
                   Q(2, UBound(Q, 2)) = Ray(n, 2)
[/B][/COLOR]               Dic(Ray(n, Ac)) = Q