Compare multiple column using dictionary VBA

Hossam_Samir

New Member
Joined
Sep 10, 2019
Messages
4
Hi everybody,

I am hoping someone might be able to help with this problem

I have 5 columns in sheet1
column A have all the names of employee that attendant today
Column B have the names of all employees of department 1
Column C have the names of all employees of department 2
and so on till column E with names of department 4

So I need to create 4 columns in sheet2 for the 4 departments every one contain the names of employees that attendant today from each department.

I already created vlookup formula to achieve that, however it takes so long to process
I believe creating a scripting dictionary for the 5 column and compare them against the first column would be much faster

any help would be mostly appreciated.
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Welcome to the Board.

Open a copy of your workbook. Press Alt-F11 to open the VBA editor. Press Alt-IM to open a new module. Paste the following code into the window that opens:

Rich (BB code):
Sub Attendees()
Dim s1 As Range, s2 As Range, i As Long, j As Long, mycol(1 To 5) As Variant
Dim ix(1 To 4) As Long, mydict(1 To 5) As Object, x As Variant, y As Variant


    Set s1 = Sheets("Sheet1").Range("A1")
    Set s2 = Sheets("Sheet2").Range("A1")
    
    For i = 1 To 5
        mycol(i) = s1.Range(s1.Cells(1, i), s1.Cells(Rows.Count, i).End(xlUp)).Value
        Set mydict(i) = CreateObject("Scripting.Dictionary")
        For j = 2 To UBound(mycol(i))
            mydict(i)(mycol(i)(j, 1)) = 1
        Next j
    Next i
    
    s2.Resize(Rows.Count, 4).ClearContents
    s2.Resize(1, 4).Value = s1.Offset(0, 1).Resize(1, 4).Value
    
    ReDim Output(1 To UBound(mycol(1)), 1 To 4)
    For Each x In mydict(1)
        For j = 2 To 5
            If mydict(j).Exists(x) Then
                ix(j - 1) = ix(j - 1) + 1
                Output(ix(j - 1), j - 1) = x
                Exit For
            End If
        Next j
    Next x
    
    s2.Offset(1).Resize(UBound(Output), 4).Value = Output
        
End Sub
Change the values in red to match your sheets. s1 should point to the upper left corner on sheet1, and s2 should be the upper left corner on sheet2. This assumes there is a header row on both sheets.

Press Alt-Q to close the editor. In Excel, press Alt-F8. Choose Attendees and click Run.

Let us know if this works for you.
 
Upvote 0
one last question
Is it possible to add a 5th column with names that do not exist in the 4 departments?
Thank you in advance
 
Upvote 0
Try this:

Code:
Sub Attendees()
Dim s1 As Range, s2 As Range, i As Long, j As Long, mycol(1 To 5) As Variant
Dim ix(1 To 5) As Long, mydict(1 To 5) As Object, x As Variant, y As Variant
Dim output() As String

    Set s1 = Sheets("Sheet1").Range("A1")
    Set s2 = Sheets("Sheet2").Range("A1")
    
    For i = 1 To 5
        mycol(i) = s1.Range(s1.Cells(1, i), s1.Cells(Rows.Count, i).End(xlUp)).Value
        Set mydict(i) = CreateObject("Scripting.Dictionary")
        For j = 2 To UBound(mycol(i))
            mydict(i)(mycol(i)(j, 1)) = 1
        Next j
    Next i
    
    s2.Resize(Rows.Count, 4).ClearContents
    s2.Resize(1, 4).Value = s1.Offset(0, 1).Resize(1, 4).Value
    s2.Offset(, 4).Value = "Other"
    
    ReDim output(1 To UBound(mycol(1)), 1 To 5)
    For Each x In mydict(1)
        For j = 2 To 5
            If mydict(j).Exists(x) Then Exit For
        Next j
        ix(j - 1) = ix(j - 1) + 1
        output(ix(j - 1), j - 1) = x
    Next x
    
    s2.Offset(1).Resize(UBound(output), 5).Value = output
        
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,507
Messages
6,114,029
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top