VBA: find all matches of one list in each cell of another list and create combined rank

[fxrexcel]

I have the following problem with VBA:

I have a list of names of persons with a rank (either "1" or "2", see below) and I want to search their number of occurrences in another table and add up the ranks.

Person Data:

Person	Rank
A	1
B	2
K	2
P	1
U	2
T	1
...	...

<tbody>
</tbody>

Company Data:

• red is what needs to be written in Col "Combined Rank")
• In my Company Data, the names of the persons data are sometimes followed by random brackets and/or spaces and then brackets

Company	Persons	Combined Rank
C1	A(), B (..)	3 [= Rank(A)+Rank(B)=1 + 2]
C2	K	2
C3	K [--], P, A, T	5 [=2 + 1 + 1 + 1]
C4	Q	0
C5	-	0
C6	A, U{ff}	3 [=1 + 2]
...	...

<tbody>
</tbody>

Thanks a lot for your help.

 

[Eric W]

I don't know if you actually need VBA, but you can do that with just a formula:

	A	B	C	D	E	F	G
1	Person	Rank		Company	Persons	Combined Rank
2	A	1		C1	A(), B (..)	3
3	B	2		C2	K	2
4	K	2		C3	K [--], P, A, T	5
5	P	1		C4	Q	0
6	U	2		C5	-	0
7	T	1		C6	A, U{ff}	3

<tbody>
</tbody>

Sheet7​

Array Formulas Cell Formula F2 {=SUM(IF(ISNUMBER(FIND($A$2:$A$7,E2)),$B$2:$B$7))} <tbody> </tbody> Entered with Ctrl+Shift+Enter. If entered correctly, Excel will surround with curly braces {}. Note: Do not try and enter the {} manually yourself

<tbody>
</tbody>

Let us know if this works, or if you need VBA.

 

[fxrexcel]

Hi Eric,

thanks for your reply. I actually need VBA.

thx

 

[fxrexcel]

Any idea, anyone? Thanks!

 

[MickG]

Try this:-
"Person" Table starts "A2"
"Company" Table starts "D2"
Results in column "F".

[COLOR="Navy"]Sub[/COLOR] MG16Aug19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] num [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   .Item(Dn.Value) = Dn.Offset(, 1)
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("E2", Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] n = 1 To Len(Dn.Value)
        [COLOR="Navy"]If[/COLOR] Dn.Characters(n, 1).Text >= Chr(65) And Dn.Characters(n, 1).Text <= Chr(90) [COLOR="Navy"]Then[/COLOR]
            num = num + .Item(Dn.Characters(n, 1).Text)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
Dn.Offset(, 1).Value = num: num = 0
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[fxrexcel]

Hi Mick,

Thanks for that. The names are actual names and not just "A","B,"C", etc.

How do you change the code for that?

Thanks a lot for your help!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG18Aug50
im Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] num [COLOR="Navy"]As[/COLOR] Double, sp [COLOR="Navy"]As[/COLOR] Variant, nstr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   .Item(Dn.Value) = Dn.Offset(, 1)
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("E2", Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] n = 1 To Len(Dn.Value)
        [COLOR="Navy"]If[/COLOR] UCase(Dn.Characters(n, 1).Text) >= Chr(65) And UCase(Dn.Characters(n, 1).Text) <= Chr(90) [COLOR="Navy"]Then[/COLOR]
            nstr = nstr & Dn.Characters(n, 1).Text
        [COLOR="Navy"]Else[/COLOR]
         nstr = nstr & ","
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
    sp = Split(nstr, ",")
    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(sp)
       [COLOR="Navy"]If[/COLOR] .exists(sp(n)) [COLOR="Navy"]Then[/COLOR]
        num = num + .Item(sp(n))
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
Dn.Offset(, 1).Value = num: num = 0: nstr = ""
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[fxrexcel]

it worked, thanks! great job

 

[MickG]

You're welcome