Excel VBA Macro to compare employee data head wise between multiple sheet and give out to separate sheet

Query: Hi I have employee master data in two or sometimes three or more sheets, I want to match data in all sheets and get the comparison in new sheets, where macro to check head wise employee wise amount and highlight if miss match.

Ans:

Since there are multiple sheets to compare, we need to loop through all sheets & take unique employee number from all sheets, and similarly extract unique headers from all sheets.

Once we have extracted the same we can generate the ouput in new sheet where we can pull employee details and corresponding head wise amount from different sheet, then we can match amount in next column and highlight the same.

Code goes here:

Option Explicit
Sub Generate_Diff_V2()
Dim key As Variant
Dim cell As Range, cell2 As Range
Dim wb As Workbook
Dim i As Integer, j As Integer
Dim dict As Object, dict2 As Object
Dim cell3 As Range
Set wb = ThisWorkbook
Dim app

Set app = Application.WorksheetFunction
Set dict = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
    
Application.ScreenUpdating = False
dict.RemoveAll
dict2.RemoveAll

For i = 1 To wb.Worksheets.Count
If Sheets(i).Name <> "Output" Then

Sheets(i).Select
For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Not dict.exists(Val(cell)) Then
dict.Add Val(cell), cell.Offset(0, 1)
End If
Next

For Each cell In Range(Range("C1"), Cells(1, Range("A1").End(xlToRight).Column))
If Not dict2.exists(cell.Value) Then
dict2.Add cell.Value, cell.Value
End If
Next

End If

Next i
     
Sheets("Output").Select
Cells.Clear
Cells(3, 1).Resize(dict.Count) = Application.Transpose(dict.Keys)

For Each cell3 In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
cell3.Offset(0, 1).Value = dict(Val(cell3))
Next cell3

Dim k As Integer
Dim rr As Long, cc As Long

k = 2
Cells(2, 1).Value = "ID"
Cells(2, 2).Value = "Name"

For Each key In dict2.Keys
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Output" Then


Cells(1, k + 1).Value = key
Cells(2, k + 1).Value = Sheets(i).Name

On Error Resume Next
cc = 0
cc = Sheets(i).Range("A1:ZZ1").Find(key, LookIn:=xlValues).Column

For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
On Error Resume Next
rr = 0
rr = Sheets(i).Range("A1:A100000").Find(cell.Value, LookIn:=xlValues).Row
If rr <> 0 And cc <> 0 Then
cell.Offset(0, k).Value = Sheets(i).Cells(rr, cc).Value
Else
cell.Offset(0, k).Value = 0
End If
Next cell

k = Range("ZZ3").End(xlToLeft).Column  'k + 6

End If
Next i

Cells(2, k + 1).Value = "Diff"
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
'For j = 1 To Worksheets.Count - 1 'dict2.Count
'cell.Offset(0, k).Value = cell.Offset(0, k).Value - cell.Offset(0, k - j).Value
'Next j
j = Worksheets.Count - 1
cell.Offset(0, k).Value = app.Max(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1))) _
= app.Min(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1)))
If Not cell.Offset(0, k).Value Then
cell.Offset(0, k).Interior.Color = vbRed
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column + 1 'k + 6

Next key

Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

You can also download sample file from here:

Post your query & comments below, you can also post your query at www.ExcelVbaLab.com

Cheers!!