Compare multiple column using dictionary VBA

[Hossam_Samir]

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.

 

[Eric W]

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:

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.

 

[Hossam_Samir]

Wow, Thank you very much Eric W.
It works like a charm.

 

[Eric W]

Happy to help.

 

[Hossam_Samir]

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

 

[Eric W]

Try this:

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

 

[Hossam_Samir]

Thanks again Eric.
I really appreciate all of your help