How to go about

[Danny54]

I'm lost on how to go about taking the follow data from a excel spreadsheet and creating the listing on the bottom.

My data looks like this (sheet1)

Company Product#
A 10
A 11
A 12
A 13

B 15
B 16
B 17

C 11
C 12



The output would summarize sheet1 and present a new sheet like this

Company Total Products Notes
A 4 50% contained in this company is found in Company C
B 3
C 2 100% contained in this ocmpany is found in Company A


In summary, look at the input data sheet to determine if any one group product#s are found in other groups and if so, what is the percentage


I've investigated using a array, then a collection and finally a dictionary which only confused the issue.

I think i'm overthinking the solution.

Any help would be appreciated.

Thanks

 

[MickG]

Try this initially for data in columns "A & B" and Output in column "C" On, against Company Areas.

[COLOR="Navy"]Sub[/COLOR] MG03Jul16
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Gn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    Rw = 0
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Gn [COLOR="Navy"]In[/COLOR] Rng.Areas
        [COLOR="Navy"]If[/COLOR] Not Gn.Address = Dn.Address [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
                [COLOR="Navy"]If[/COLOR] Not IsError(Application.Match(R, Gn, 0)) [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] R
            Dn(1).Offset(, Rw) = Format(c / Dn.Count, "0%") & "   " & Gn(1).Offset(, -1): c = 0
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Gn
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MickG]

Try this for Data on "sheet1" and results on "Sheet2".

[COLOR="Navy"]Sub[/COLOR] MG03Jul26
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Gn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ReDim ray(1 To 2, 1 To 1)
ray(1, 1) = "Company Total": ray(2, 1) = "Product Notes"
p = 1
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    Rw = 0
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Gn [COLOR="Navy"]In[/COLOR] Rng.Areas
        [COLOR="Navy"]If[/COLOR] Not Gn.Address = Dn.Address [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
                [COLOR="Navy"]If[/COLOR] Not IsError(Application.Match(R, Gn, 0)) [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] R
                 p = p + 1
                ReDim Preserve ray(1 To 2, 1 To p)
                ray(1, p) = "Company " & Dn(1).Offset(, -1)
                ray(2, p) = Format(c / Dn.Count, "0%") & " Co " & Dn(1).Offset(, -1) & " in Co " & Gn(1).Offset(, -1)
                c = 0
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Gn
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(p, 2)
    .Parent.Columns("A:B").ClearContents
    .Value = Application.Transpose(ray)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Danny54]

Thanks for the gentle push in resolving this opportunity. When I run the code in step mode I never get into the "If Not Gn.Address = Dn.Address Then" code section.
Thoughts?

 

[MickG]

Your data is laid out with an empty row between each set of "company/products", the code then works with that separated data.
Does your data have blank rows between each set of "Company/Products" ????

 

[Danny54]

no blank between groups

 

[MickG]

Try this :- Data sheet1, Results sheet2.

[COLOR="Navy"]Sub[/COLOR] MG04Jul41
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Gn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ReDim ray(1 To 2, 1 To 1)
ray(1, 1) = "Company Total": ray(2, 1) = "Product Notes"
p = 1
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Offset(, -1).Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Offset(, -1).Value) = Union(.Item(Dn.Offset(, -1).Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] n = 0 To .Count - 1
        [COLOR="Navy"]For[/COLOR] nn = 0 To .Count - 1
            [COLOR="Navy"]If[/COLOR] Not .Items()(n).Address = .Items()(nn).Address [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Items()(n)
                [COLOR="Navy"]If[/COLOR] Not IsError(Application.Match(R, .Items()(nn), 0)) [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] R
                 p = p + 1
                ReDim Preserve ray(1 To 2, 1 To p)
                ray(1, p) = "Company " & .Items()(n)(1).Offset(, -1)
                ray(2, p) = Format(c / .Items()(n).Count, "0%") & " Co " & .Items()(n)(1).Offset(, -1) & " in Co " & .Items()(nn)(1).Offset(, -1)
                c = 0
           [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] nn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(p, 2)
    .Parent.Columns("A:B").ClearContents
    .Value = Application.Transpose(ray)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Danny54]

Perfect, and I can see I have much to learn. I never used the union and barely into using Scripting.Dictionary.

Thanks so much.

 

[MickG]

You're very welcome