Count String A with respect to Grouped String B

[capson]

Hello I am pretty new to excel and was hoping someone could help with this.

I have two columns Column A Has grouped Names and Column B has kinds of Relationships


I need to count all the kinds of Relationships: Self, Boss, Peer, Direct Report, Other for each Name in column A


I can count ALL the Relationships with the Sub below but I can not find or figure out how to count with respect to the name group.


The names constantly change so I can not hard code them


Example

Betty Sue Self(1) Boss(1) Peer(3) Direct Report(1) Other(1)


Thanks


In column A I have "Grouped Names


Betty Sue
Betty Sue
Betty Sue
Betty Sue
Betty Sue
Betty Sue
Fred Anderson
Fred Anderson
Fred Anderson
Molly Capra
Molly Capra
Molly Capra
Molly Capra
Molly Capra




In Column B I have Relationships


Self
Boss
Peer
Peer
Other
Direct Report
Peer
Self
Peer
Direct Report
Direct Report
Direct Report
Boss




My Sub for counting ALL Relationships is




Sub Report()


Dim rng As range
Dim LastRow As Long
Dim iVal As Integer
Dim jVal As Integer
Dim kVal As Integer
Dim lVal As Integer
Dim mVal As Integer



Windows("LimeSurveyTokenTable.xlsx").Activate
With Sheets("sheet1")
LastRow = .range("D" & .Rows.Count).End(xlUp).Row
End With


iVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Self")
jVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Boss")
kVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Peer")
lVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Direct Report")
mVal = Application.WorksheetFunction.CountIf(range("D2:D" & LastRow), "Other")

MsgBox "Self'es:" & " " & iVal & " " & "Boss'es:" & " " & jVal & " " & "Peers:" & " " & kVal & " " & "Direct Reports:" & " " & lVal & " " & "Others:" & " " & mVal


End Sub

 

[MickG]

Try this:-
Your data start "A1" (columns "A & B")
Resuts Via Msgbox.

[COLOR="Navy"]Sub[/COLOR] MG28May40
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic     [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Str     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
   [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMode = 1
   [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
        
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), 1
            [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Dn.Value).Item(Dn.Offset(, 1).Value)
                    Q = Q + 1
                Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = Q
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
   
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
       Str = Str & k & " :- "
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
               Str = Str & p & " (" & Dic(k).Item(p) & ") , "
            [COLOR="Navy"]Next[/COLOR] p
        Str = Str & Chr(10)
    [COLOR="Navy"]Next[/COLOR] k
MsgBox Str
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[capson]

That worked perfectly

Thank you
Tim

 

[MickG]

Your're welcome
Regds Mick

 

[capson]

MickG, I have managed to paste the entire content of the MsgBox in to a cell but I would like to each line of the MsgBox starts in its own cell.

Is there a way to do this?

Thanks
Tim

 

[MickG]

Change the code, msgbox for Range("E4") as below in red:-

  Next k
Range("E4") = Str
End Sub

If you require its also possible to place each name in a row, in one column, and each set of "relationships" in the same row, next column.

 

[capson]

MickG, sorry for not being clear, I trying for, if there were three names Betty Sue, Fred Anderson, Molly Capra then

Betty Sue Self(1) Boss(1) Peer(3) Direct Report(1) Other(1)
Fred Anderson Self(1) Boss(1) Peer(3) Direct Report(1) Other(1)
Molly Capra Self(1) Boss(1) Peer(3) Direct Report(1) Other(1)

Each would be in there own Row E4, F5, G6 respectively and the elements of each row would be in there own cell i.e

Betty Sue in cellE4 Self(1) in cell E5 Boss(1) in cell E6 Peer(3) in cell E7 Direct Report(1) in cell E8 Other(1) in cell E9

Thanks
Tim

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG30May41
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic     [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Str     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
   [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMode = 1
   [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
        
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), 1
            [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Dn.Value).Item(Dn.Offset(, 1).Value)
                    Q = Q + 1
                Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = Q
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Dim[/COLOR] C [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
    C = 4
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
       C = C + 1
       Ac = 1
       Cells(Ac, C) = k
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
               Ac = Ac + 1
                Cells(Ac, C) = p & " (" & Dic(k).Item(p) & ")"
            [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[capson]

Mick,

Thank you for this I felt this was a lot to ask, I appreciate it. It works as I had hoped.