Comparing tables and printing discrepancies

Question

Here's my first VBA project. I have some very limited Python experience, and this is my first VBA project. I'm sure I could have done it a lot more simply, but I just stuck with what I knew, and googled what I didn't, so feedback is very welcome.

The basic purpose is to compare a table from one sheet (OP) with a table from another (Payroll) and print the discrepancies in a third sheet (Results).

One last thing I want to do, but can't figure out (without using GoTo, which I read is bad) is to protect the worksheets after I Exit Sub on lines 22, 31, etc. (code for protecting sheets is already written in line 130 - 138.

Sub Macro1()

Dim counter As Integer
Set OPdata = New Dictionary
Set Payrolldata = New Dictionary
Set HRIDnames = New Dictionary

'Unprotects sheets
Worksheets("Results").Unprotect Password:=""
Worksheets("OP").Unprotect Password:=""
Worksheets("Payroll").Unprotect Password:=""

' Clears Results worksheet
Worksheets("Results").Activate
Range("A3:L10000").ClearContents

' Looks for missing data in the OP worksheet
Worksheets("OP").Activate
Range("A2").Select
If IsEmpty(ActiveCell) Then
    MsgBox "There is data missing"
    Exit Sub
End If

Worksheets("OP").Activate
Range("A1").CurrentRegion.Select
For Each C In Selection
    If C = "" Then
    C.Select
    MsgBox "There is data missing"
    Exit Sub
    End If
Next

' Looks for missing data in the Payroll worksheet
Worksheets("Payroll").Activate
Range("A2").Select
If IsEmpty(ActiveCell) Then
    MsgBox "There is data missing"
    Exit Sub
End If

Worksheets("Payroll").Activate
Range("A1").CurrentRegion.Select
For Each C In Selection
    If C = "" Then
    C.Select
    MsgBox "There is data missing"
    Exit Sub
    End If
Next

' Populate OPdata dictionary
Worksheets("OP").Activate
Range("A2", ActiveCell.End(xlDown)).Select
For Each cl In Selection
    OPdata.Add cl.Value, cl.Offset(0, 2).Value & " " & cl.Offset(0, 3).Value
    HRIDnames.Add cl.Value, cl.Offset(0, 1).Value
Next

' Populate Payrolldata dictionary
Worksheets("Payroll").Activate
Range("A2", ActiveCell.End(xlDown)).Select
For Each cl In Selection
    Payrolldata.Add cl.Value, cl.Offset(0, 2).Value & " " & cl.Offset(0, 3).Value
    If HRIDnames.Exists(cl.Value) = False Then
    HRIDnames.Add cl.Value, cl.Offset(0, 1).Value
    End If
Next

' finds unique values in OPdata and prints them to columns A:C
Worksheets("Results").Activate
Range("A3").Select
For Each i In OPdata
    If Payrolldata.Exists(i) = False Then
    ActiveCell = i
    ActiveCell.Offset(0, 2).Select
    ActiveCell = OPdata.Item(i)
    ActiveCell.Offset(1, -2).Select
    End If
Next

' finds unique values in Payrolldata and prints them to columns E:G
Worksheets("Results").Activate
Range("E3").Select
For Each i In Payrolldata
    If OPdata.Exists(i) = False Then
    ActiveCell = i
    ActiveCell.Offset(0, 2).Select
    ActiveCell = Payrolldata.Item(i)
    ActiveCell.Offset(1, -2).Select
    End If
Next

' Finds salary discrepencies and prints them to columns I:L
Worksheets("Results").Activate
Range("I3").Select
For Each i In OPdata
    If Payrolldata.Exists(i) Then
        If Not OPdata.Item(i) = Payrolldata.Item(i) Then
        ActiveCell = i
        ActiveCell.Offset(0, 2).Select
        ActiveCell = OPdata.Item(i)
        ActiveCell.Offset(0, 1).Select
        ActiveCell = Payrolldata.Item(i)
        ActiveCell.Offset(1, -3).Select
        End If
    End If
Next

' Prints names
Sheets("Results").Range("A3").Select
While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1) = HRIDnames.Item(ActiveCell.Value)
    ActiveCell.Offset(1).Select
Wend

Sheets("Results").Range("E3").Select
While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1) = HRIDnames.Item(ActiveCell.Value)
    ActiveCell.Offset(1).Select
Wend

Sheets("Results").Range("I3").Select
While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1) = HRIDnames.Item(ActiveCell.Value)
    ActiveCell.Offset(1).Select
Wend

' Reprotect Worksheets
Worksheets("Results").Protect Password:=""
Worksheets("OP").Protect Password:=""
Worksheets("Payroll").Protect Password:=""

' Success message
If WorksheetFunction.CountA(Range("A3:L3")) = 0 Then
MsgBox ("Congratulations! OurPeople and Payroll reconcile exactly!")
End If

End Sub

Answer 1

1. Always put Option Explicit at the top of your modules (Tools - Options - Editor - Require Variable Declaration).
2. Never select or activate something unless it's necessary
3. Limit reading and writing to worksheets as it's an expensive operations
4. When you have code that looks similar to other code, move it to another procedure

Here's some revised code

Sub Macro2()

    Dim dcOp As Scripting.Dictionary, dcPay As Scripting.Dictionary, dcHri As Scripting.Dictionary
    Dim shPay As Worksheet, shOp As Worksheet, shResults As Worksheet
    Dim vaWrite As Variant
    Dim vKey As Variant
    Dim lCnt As Long
    Dim bFail As Boolean

    'The only acceptable use of goto imho
    On Error GoTo ErrHandler

    Set dcOp = New Scripting.Dictionary
    Set dcPay = New Scripting.Dictionary
    Set dcHri = New Scripting.Dictionary

    'Set sheet variables so that if a sheet name changes, you only
    'have to change it in one place. Or better yet, refer to sheets
    'by their codename
    Set shPay = Worksheets("Payroll")
    Set shOp = Worksheets("OP")
    Set shResults = Worksheets("Results")

    shPay.Unprotect ""
    shOp.Unprotect ""
    shResults.Unprotect ""

    ' Clears Results worksheet
    'Don't activate a sheet if you don't need to
    shResults.Range("A3:L10000").ClearContents

    ' Looks for missing data in the OP worksheet
    'Value is the default property of Range, but always use it for clarity
    'By raising an error, you invoke the error handler where you can do
    'things like protect sheets
    If IsEmpty(shOp.Range("A2").Value) Or IsEmpty(shPay.Range("A2").Value) Then
        Err.Raise 9999, , "There is data missing"
    End If

    'Repeating code should be factored out to a different function or sub
    If DataMissing(shOp.Range("A1").CurrentRegion) Or DataMissing(shPay.Range("A1").CurrentRegion) Then
        Err.Raise 9999, , "There is data missing"
    End If

    ' Populate OPdata dictionary
    GetData shOp, dcOp, dcHri
    GetData shPay, dcPay, dcHri

    vaWrite = GetUnique(dcOp, dcPay, dcHri, bFail)
    shResults.Range("A3").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite

    vaWrite = GetUnique(dcPay, dcOp, dcHri, bFail)
    shResults.Range("E3").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite

    'Find salary discrepencies.
    'If you're going to fill cells one-by-one, don't activate them, just offset
    For Each vKey In dcOp.Keys
        If dcPay.Exists(vKey) Then
            If dcOp.Item(vKey) <> dcPay.Item(vKey) Then
                bFail = True
                With shResults.Range("I3")
                    .Offset(lCnt, 0).Value = vKey
                    If dcHri.Exists(vKey) Then
                        .Offset(lCnt, 1).Value = dcHri.Item(vKey)
                    End If
                    .Offset(lCnt, 2).Value = dcPay.Item(vKey)
                    .Offset(lCnt, 3).Value = dcOp.Item(vKey)
                End With
                lCnt = lCnt + 1
            End If
        End If
    Next vKey

    If Not bFail Then MsgBox "Congratulations! OurPeople and Payroll reconcile exactly!"

ErrExit:
    'If no errors, this executes. If there are errors, ErrHandler resumes execution here
    'so the sheets get protected no matter what
    shOp.Protect
    shPay.Protect
    shResults.Protect
    Exit Sub 'single point of exit from the sub

ErrHandler:
    'Err.Raise comes here
    MsgBox Err.Description
    Resume ErrExit

End Sub

Private Function DataMissing(rRng As Range) As Boolean

    Dim rBlanks As Range

    On Error Resume Next
        Set rBlanks = rRng.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0

    DataMissing = Not rBlanks Is Nothing

End Function

Private Sub GetData(sh As Worksheet, ByRef dcData As Scripting.Dictionary, ByRef dcExcept As Scripting.Dictionary)
    'ByRef means that whatever changed you make to the variable will still be there
    'when you get back to the calling procedure

    Dim vaData As Variant
    Dim i As Long 'VB converts all integers to Long anyway, so just use Long

    'Read data once in a big chunk rather than cell-by-cell
    vaData = sh.Range("A2", sh.Range("A2").End(xlDown)).Resize(, 3).Value

    For i = LBound(vaData, 1) To UBound(vaData, 1)
        dcData.Add vaData(i, 1), vaData(i, 3) & Space(1) & vaData(i, 4)
        If Not dcExcept.Exists(vaData(i, 1)) Then
            dcExcept.Add vaData(i, 1), vaData(i, 2)
        End If
    Next i

End Sub

Private Function GetUnique(dcFirst As Scripting.Dictionary, dcLast As Scripting.Dictionary, dcNames As Scripting.Dictionary, ByRef bFail As Boolean) As Variant

    Dim aReturn() As Variant
    Dim lCnt As Long
    Dim vKey As Variant

    ReDim aReturn(1 To dcFirst.Count, 1 To 3)

    For Each vKey In dcFirst.Keys
        If Not dcLast.Exists(vKey) Then
            bFail = True
            lCnt = lCnt + 1
            aReturn(lCnt, 1) = vKey
            If dcNames.Exists(vKey) Then aReturn(lCnt, 2) = dcNames.Item(vKey)
            aReturn(lCnt, 3) = dcFirst.Item(vKey)
        End If
    Next vKey

    GetUnique = aReturn

End Function