VBA Dictionary - unique Account no with Items

[Mallesh23]

Hi Team ,

Need dictionary help, I want unique account Number ,
By comparing current months column to Previous Columns and vice versa.

Also I want Dictionary Items of that account no.


Below is my attempted code, which help in extracting unique account by Comparing both the Columns.
in G AND in Column J.

Sub Add_Unique_Value()
  
  Dim sht_C As Worksheet
  Set sht = ThisWorkbook.Worksheets(1)
  
   
   Dim ary_base As Variant
   Dim ary_Compare As Variant


   'Store two Columns into Array
        With sht
                ary_base = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value2
        End With

        With sht
            ary_Compare = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Value2
        End With
    
   Dim dict_CurrentMonth As Dictionary
   Set dict_CurrentMonth = Compare2List(ary_Compare, ary_base)
   
   
  sht.Range("d2").Resize(dict_CurrentMonth.Count).Value = Application.Transpose(dict_CurrentMonth.Keys)


    Dim Dict_PreviousMonth As Dictionary
   Set Dict_PreviousMonth = Compare2List(ary_base, ary_Compare)
   
sht.Range("F2").Resize(Dict_PreviousMonth.Count).Value = Application.Transpose(Dict_PreviousMonth.Keys)


End Sub
   


Public Function Compare2List(ary_base As Variant, ary_Compare As Variant) As Dictionary
   
    Dim i As Long
    Dim Dict As New Scripting.Dictionary

     With Dict

            For i = LBound(ary_base) To UBound(ary_base)
                .Item(ary_base(i, 1)) = "Empty"
                 .Item(ary_base(i, 1)) = Array(ary_base(i, 1))

            Next i

            For i = LBound(ary_Compare) To UBound(ary_Compare)
                If .Exists(ary_Compare(i, 1)) Then .Remove (ary_Compare(i, 1))
            Next i

    End With

    Set Compare2List = Dict

End Function

Input Data,

Book1
	A	B	C	D	E
1	Previous Months Account Number	Sales Man		Current Months Account Number	SalesMan
2	70	Dhoni		27	Dhoni
3	10	sachin		36	sachin
4	20	Sehwag		39	Sehwag
5	90	Deepika		19	Deepika
6	30	Katrina		28	Katrina
7	70	Saif		30	Saif
8	80	Sharukh		31	Sharukh
9	20	Jadeja		24	Jadeja
10	10	Pranay		18	Pranay
11	90	Vinay		22	Vinay
12	30	Ponting		38	Ponting
13	90	Petersen		80	Petersen
14	40	Gilchrist		16	Gilchrist
15	90	Dravid		21	Dravid
16	40	Lara		23	Dhoni
17				17	sachin
18				35	Sehwag
19				32	Deepika
20				32	Katrina
21				32	Saif
22				32	Sharukh
23				32	Jadeja
24				32	Pranay
25				32	Vinay
26				32	Ponting
27				32	Petersen
Sheet1

Expected Output , Column g and J able to extract via vba,
Got salesman by manually vlookup. Thanks

Book1
	G	H	I	J	K
1	Current Months Record not Found in Previous	SalesMan		Previous Months Record not Found in Previous	SalesMan
2	27	Dhoni		70	Dhoni
3	36	sachin		10	sachin
4	39	Sehwag		20	Sehwag
5	19	Deepika		90	Deepika
6	28	Katrina		40	Gilchrist
7	31	Sharukh
8	24	Jadeja
9	18	Pranay
10	22	Vinay
11	38	Ponting
12	16	Gilchrist
13	21	Dravid
14	23	Dhoni
15	17	sachin
16	35	Sehwag
17	32	Deepika
Sheet1

Cell Formulas
Range	Formula
H2:H17	H2	=VLOOKUP(G2,$D$2:$E$27,2,0)

Thanks
mg

 

[DanteAmor]

Try the following.
Considering the input data in columns A, B, D and E.
Results include accounts and salesman

Sub Unique_Account()
  Dim arrA As Variant, arrD As Variant
  Dim dic1 As Object, dic2 As Object
  Dim i As Long
  
  arrA = Range("A2", Range("B" & Rows.Count).End(3)).Value2
  arrD = Range("D2", Range("E" & Rows.Count).End(3)).Value2
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(arrA)
    If Not dic1.exists(arrA(i, 1)) Then dic1(arrA(i, 1)) = arrA(i, 2)
  Next
  
  For i = 1 To UBound(arrD)
    If Not dic1.exists(arrD(i, 1)) Then
      If Not dic2.exists(arrD(i, 1)) Then dic2(arrD(i, 1)) = arrD(i, 2)
    Else
      dic1.Remove arrD(i, 1)
    End If
  Next
  
  Range("G2").Resize(dic2.Count, 2).Value = Application.Transpose(Array(dic2.keys, dic2.items))
  Range("J2").Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
End Sub

 

[Mallesh23]

Hi Danteamor,

Thanks for such a nice code, will check and revert.

Thanks
mg

 

[Mallesh23]

Hi DanteAmor,

Perfect ! your code is giving correct output ?.

1) if there is a blank in any cell dictionary should not add blank as a key.
2) Can we add multiple columns into Dictionary Items like Array(arrD(i,2)),arrd(i,3))
and how to print the same.

I have added extra Amount Column, also there is one blank cell ,
blank should not be key.
how to add amount column to dictionary Items in the same code and print the output.



Below is Input Columns with Expected output.

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	Previous Months Account Number	Sales Man		Current Months Account Number	SalesMan	amount			DictionaryKEY	DictionaryItem1	DictionaryItem -2
2	70	Dhoni		27	Dhoni	4201			27	70	Dhoni
3	10	sachin		36	sachin	2714			36	10	sachin
4	20	Sehwag		39	Sehwag	4623			39	20	Sehwag
5	90	Deepika		19	Deepika	2543			19	90	Deepika
6	30	Katrina		28	Katrina	2237			28	40	Gilchrist
7	70	Saif							31	Sharukh	2298
8	80	Sharukh		30	Saif	1377			24	Jadeja	2381
9	20	Jadeja		31	Sharukh	2298			18	Pranay	2105
10	10	Pranay		24	Jadeja	2381			22	Vinay	1142
11	90	Vinay		18	Pranay	2105			38	Ponting	3534
12	30	Ponting		22	Vinay	1142			16	Gilchrist	4714
13	90	Petersen		38	Ponting	3534			21	Dravid	2149
14	40	Gilchrist		80	Petersen	4693			23	Dhoni	2682
15	90	Dravid		16	Gilchrist	4714			17	sachin	2279
16	40	Lara		21	Dravid	2149			35	Sehwag	1578
17				23	Dhoni	2682			32	Deepika	2027
18				17	sachin	2279
19				35	Sehwag	1578
20				32	Deepika	2027
21				32	Katrina	4484
22				32	Saif	2759
23				32	Sharukh	2895
24				32	Jadeja	4437
25				32	Pranay	3700
26				32	Vinay	4881
27				32	Ponting	4574
28				32	Petersen	1074
Sheet1

Cell Formulas
Range	Formula
K7:K17	K7	=VLOOKUP(I7,D9:F34,3,0)

Thanks
mg

 

[DanteAmor]

Below is Input Columns with Expected output.

I don't understand the output.
Why in the output you have 27-70-Dhoni and you don't have 31-80-2298 or 32-90-2027?
It is very confusing for me.
It looks like a new macro and maybe a new thread you should create.

 

[Mallesh23]

Hi Danteamor,

Why in the output you have 27-70-Dhoni and you don't have 31-80-2298 or 32-90-2027?

Regarding above question, you have used dictionary and it will not add duplicate keys, it replace existing key with new key.
in my question there were duplicate Keys entries... because of this there is a confusion, But in Actual data there will not be duplicates.

and later I brought the anser using vlookup, which gives First Matching values.

Your approach is right, I checked it gives correct ouput. ignore my expected ouput,
Just i want to to add another columns into Items.... like Array below and ignore blank cell value as a key.

If Not dic2.exists(arrD(i, 1)) Then dic2(arrD(i, 1)) = Array(arrD(i, 2),arrD(i, 3))


hope it will clear , else I will post fresh thread with actual requirement.

Thanks
mg

 

[DanteAmor]

ignore blank cell value as a key

Try this:

Sub Unique_Account()
  Dim arrA As Variant, arrD As Variant
  Dim dic1 As Object, dic2 As Object
  Dim i As Long
  
  arrA = Range("A2", Range("B" & Rows.Count).End(3)).Value2
  arrD = Range("D2", Range("E" & Rows.Count).End(3)).Value2
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(arrA)
    if arrA(i,1) <> "" then If Not dic1.exists(arrA(i, 1)) Then dic1(arrA(i, 1)) = arrA(i, 2)
  Next
  
  For i = 1 To UBound(arrD)
    if arrD(i,1) <> "" then
    If Not dic1.exists(arrD(i, 1)) Then
      If Not dic2.exists(arrD(i, 1)) Then dic2(arrD(i, 1)) = arrD(i, 2)
    Else
      dic1.Remove arrD(i, 1)
    End If
    End If
  Next
  
  Range("G2").Resize(dic2.Count, 2).Value = Application.Transpose(Array(dic2.keys, dic2.items))
  Range("J2").Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
End Sub

---------------------------------------------------------------------------------------------------

Just i want to to add another columns into Items

I still don't understand that part and without a real example of your data and the expected result, I can't help you.

 

[Mallesh23]

Hi Danteamor,

Thanks once again for your help, its working, ?

reg extra column help, I will correct my input and expected output and post a new thread.


Thanks
mg