VB count unique values based on match

[288enzo]

Hi all,

First, I'm running on MS Office Pro Plus 2016.

I have two sheets, (sheet1) is a list of email addresses in column A.
The second sheet (sheet2) has in column A a list of values, and in column B is the corresponding email address associated with the value in column A.

My goal here is to create a VB script that will match the email address in sheet1 column A with the email addresses in sheet2 column B, then give me the output of total unique values based on each matching email addresses in column B sheet1. I sure hope that makes sense. Thank you

Book1
	A	B
1	Email	Unique
2	email1@email.com
3	email2@email.com
4	email3@email.com
5	email4@email.com
6	email5@email.com
Sheet1

Book1
	A	B
1	1	email1@email.com
2	1	email3@email.com
3	1	email5@email.com
4	2	email1@email.com
5	2	email3@email.com
6	2	email1@email.com
7	2	email3@email.com
8	2	email1@email.com
9	2	email3@email.com
10	3	email2@email.com
11	3	email3@email.com
12	3	email4@email.com
13	3	email5@email.com
14	10	email2@email.com
15	10	email3@email.com
16	10	email5@email.com
17	9	email1@email.com
18	9	email2@email.com
19	9	email3@email.com
20	9	email5@email.com
21	4	email1@email.com
22	4	email3@email.com
23	4	email5@email.com
24	5	email1@email.com
25	5	email2@email.com
26	5	email3@email.com
27	5	email4@email.com
28	5	email5@email.com
29	6	email1@email.com
30	6	email3@email.com
31	6	email5@email.com
32	7	email3@email.com
33	7	email5@email.com
34	8	email3@email.com
35	8	email5@email.com
36	9	email1@email.com
37	9	email2@email.com
38	9	email3@email.com
39	9	email5@email.com
40	11	email1@email.com
41	11	email2@email.com
42	11	email3@email.com
43	11	email4@email.com
44	11	email5@email.com
45	12	email1@email.com
46	12	email2@email.com
47	12	email3@email.com
48	12	email4@email.com
49	12	email5@email.com
50	10	email1@email.com
51	10	email2@email.com
52	10	email3@email.com
53	10	email5@email.com
54	10	email1@email.com
55	10	email2@email.com
56	10	email3@email.com
57	10	email5@email.com
58	10	email1@email.com
59	10	email2@email.com
60	10	email3@email.com
61	10	email5@email.com
62	10	email1@email.com
63	10	email2@email.com
64	10	email3@email.com
65	10	email5@email.com
66	13	email1@email.com
67	13	email3@email.com
68	13	email5@email.com
69	14	email3@email.com
70	14	email5@email.com
71	14	email1@email.com
72	14	email3@email.com
73	14	email5@email.com
74	14	email1@email.com
75	14	email3@email.com
76	14	email5@email.com
77	14	email1@email.com
78	14	email3@email.com
79	14	email5@email.com
80	15	email3@email.com
81	16	email3@email.com
82	17	email3@email.com
Sheet2

 

[288enzo]

Technically, I really only need to figure out what the formula would be. I can always use the formula in my script. Thanks again.

 

[JEC]

Make sure you have headers on both sheets

Sub jec()
  ar = Sheets(1).Cells(1, 1).CurrentRegion
  ar2 = Sheets(2).Cells(1, 1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For i = 2 To UBound(ar)
      For j = 2 To UBound(ar2)
         If ar(i, 1) = ar2(j, 2) Then
            If Not .exists(ar(i, 1)) Then
              .Item(ar(i, 1)) = Array(ar(i, 1), 1)
            Else
               a = .Item(ar(i, 1))
               a(1) = a(1) + 1
              .Item(ar(i, 1)) = a
            End If
         End If
       Next
     Next
    Sheets(1).Cells(2, 1).Resize(.Count, 2) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[Eric W]

Here's a formula:

Book1 (version 1).xlsb
	A	B
1	Email	Unique
2	email1@email.com	11
3	email2@email.com	6
4	email3@email.com	17
5	email4@email.com	4
6	email5@email.com	13
Sheet1

Cell Formulas
Range	Formula
B2:B6	B2	=SUM(SIGN(FREQUENCY(IF(Sheet2!$B$1:$B$82=A2,MATCH(Sheet2!$A$1:$A$82,Sheet2!$A$1:$A$82,0)),ROW(Sheet2!$A$1:$A$82)-ROW(Sheet2!$A$1)+1)))
Press CTRL+SHIFT+ENTER to enter array formulas.

Named Ranges
Name	Refers To	Cells
Sheet2!_FilterDatabase	=Sheet2!$B$1:$B$82	B2:B6

 

[288enzo]

Thank you very much to both *JEC for the script and Eric for the formula. In the end, I'm going to go with the formula only because I understand it and can manipulate it if need be. The script *JEC does the job, I'm just not at the level to understand what you did. One day I'm hoping to get there.

I used the formula in my script.

Sub ABS_0_Count()
    Range("B2").FormulaArray = "=SUM(SIGN(FREQUENCY(IF(Sheet2!$B$1:$B$82=A2,MATCH(Sheet2!$A$1:$A$82,Sheet2!$A$1:$A$82,0)),ROW(Sheet2!$A$1:$A$82)-ROW(Sheet2!$A$1)+1)))"
    Selection.AutoFill Destination:=Range("B2:B6"), Type:=xlFillDefault
End Sub

Thanks again

 

[Eric W]

Glad we could help. ?

 

[JEC]

Noticed different outcomes, compared to Eric's formula.
This adaption should give the same results

Sub jec2()
  ar = Sheets(1).Cells(1, 1).CurrentRegion
  ar2 = Sheets(2).Cells(1, 1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For i = 2 To UBound(ar)
      For j = 2 To UBound(ar2)
         If ar(i, 1) = ar2(j, 2) Then
           If .Exists(ar(i, 1)) Then
              If InStr(Join(Application.Index(.Item(ar(i, 1)), 0, 3)), ar2(j, 1)) = 0 Then
                a = .Item(ar(i, 1))
                a(1) = a(1) + 1
                a(2) = a(2) & "|" & ar2(j, 1)
               .Item(ar(i, 1)) = a
              End If
            Else
              .Item(ar(i, 1)) = Array(ar(i, 1), 1, ar2(j, 1))
          End If
        End If
      Next
    Next
  Sheets(1).Cells(2, 1).Resize(.Count, 2) = Application.Index(.Items, 0, 0)
 End With
End Sub

 

[JEC]

Maybe easier to understand

Sub jec3()
  ar = Sheets(1).Cells(1, 1).CurrentRegion
  ar2 = Sheets(2).Cells(1, 1).CurrentRegion
  
  For i = 2 To UBound(ar)
     For j = 2 To UBound(ar2)
       If ar(i, 1) = ar2(j, 2) Then
          If InStr(c00, ar2(j, 1)) = 0 Then a = a + 1
          c00 = c00 & "|" & ar2(j, 1)
       End If
     Next
     ar(i, 2) = a
     c00 = Empty: a = Empty
  Next
  Sheets(1).Cells(1, 1).CurrentRegion = ar
End Sub