Comparing information to a directory of active enployees The code is doing everything that I need it to. It's taking much too long though upwards of a couple minutes to complete the macro. Does anyone know how I code optimize this VBA code to run quicker? I'm new to VBA and I'm not quite sure how to proceed. This code will be running on roughly 35,000 lines of data.

Public Sub matchRow()

    Dim dumpSheet, referencesheet, outputSheet As Worksheet
    Dim startRow, outputRow, tempDumpRow, tempActiveRow, referenceRowCount, finishedreferenceIndex As Integer
    Dim finishedreference() As String
    Dim isExist As Boolean


    'Set sheets
    Set dumpSheet = Sheets("Dump")
    Set referencesheet = Sheets("Active Directory")
    Set outputSheet = Sheets("Output")

    'Set start row of each sheet for data
    startRow = 5
    outputRow = 5

    'Get row count from Active Depository sheet
    referenceRowCount = referencesheet.Range("B5:D5").End(xlDown).Row

    'Set index
    finishedreferenceIndex = 5

    'Re-define array
    ReDim finishedreference(5 To referenceRowCount - 1)

    'Set the start row
    tempDumpRow = startRow

    'Here I looped with OR state, you can modify it to AND start if you want
    Do While dumpSheet.Range("B" &amp; tempDumpRow) &lt;&gt; "" Or dumpSheet.Range("C" &amp; tempDumpRow) &lt;&gt; "" Or dumpSheet.Range("D" &amp; tempDumpRow) &lt;&gt; ""

        'Reset exist flag
        isExist = False

        'loop all row in Active Depository sheet
        For tempActiveRow = 5 To referenceRowCount Step 1

            'If row is not finished for checking.
            If UBound(Filter(finishedreference, tempActiveRow)) &lt; 0 Then

                'If all cell are equal
                If dumpSheet.Range("B" &amp; tempDumpRow) = referencesheet.Range("B" &amp; tempActiveRow) And _
                   dumpSheet.Range("C" &amp; tempDumpRow) = referencesheet.Range("C" &amp; tempActiveRow) And _
                   dumpSheet.Range("D" &amp; tempDumpRow) = referencesheet.Range("D" &amp; tempActiveRow) Then

                    'Set true to exist flag
                    isExist = True

                    'Store finished row
                    finishedreference(finishedreferenceIndex) = tempActiveRow

                    finishedreferenceIndex = finishedreferenceIndex + 1

                    'exit looping
                    Exit For

                End If

            End If

        Next tempActiveRow

        'Show result
        outputSheet.Range("B" &amp; outputRow) = dumpSheet.Range("B" &amp; tempDumpRow)
        outputSheet.Range("C" &amp; outputRow) = dumpSheet.Range("C" &amp; tempDumpRow)
        outputSheet.Range("D" &amp; outputRow) = dumpSheet.Range("D" &amp; tempDumpRow)

        If isExist Then
            outputSheet.Range("E" &amp; outputRow) = ""
        Else
            outputSheet.Range("E" &amp; outputRow) = "Item found in ""Dump"" but not in ""Active Directory"""
        End If

        'increase output row
        outputRow = outputRow + 1

        'go next row
        tempDumpRow = tempDumpRow + 1

    Loop

    'loop all row in Active Depository sheet
    For tempActiveRow = 5 To referenceRowCount Step 1

        'If row is not finished for checking.
        If UBound(Filter(finishedreference, tempActiveRow)) &lt; 0 Then

            'Show result
            outputSheet.Range("B" &amp; outputRow) = referencesheet.Range("B" &amp; tempActiveRow)
            outputSheet.Range("C" &amp; outputRow) = referencesheet.Range("C" &amp; tempActiveRow)
            outputSheet.Range("D" &amp; outputRow) = referencesheet.Range("D" &amp; tempActiveRow)
            outputSheet.Range("E" &amp; outputRow) = "Item found in ""Active Directory"" but not in ""Dump"""

            'increase output row
            outputRow = outputRow + 1

        End If

    Next tempActiveRow

End Sub
This is the sample dataset I created.  The OP's code suggests that the Active Directory tab has an extra row.



Always Use Worksheets CodeNames Whenever Possible

Referencing worksheets by their code names will avoid naming conflicts while working with multiple workbooks and changing the worksheet name will not break any code.  


Sheets("Active Directory") -> wsActiveDirectory
Sheets("Dump")-> wsDump
Sheets("Output") -> wsOutput


Use Constants for Magic Numbers

Using constants for values that should only be set once will make your code easier to read and maintain.  Constants will also throw an error if you try to change their values.

Before


startRow = 5
outputRow = 5



After


  


Const startRow As Long = 5, outputRow As Long = 5

Matching Lists

Dictionaries are optimised for fast lookups.  Using a Scripting.Dictionary will match the values will easily make the code run 100 times faster.  

The trick is to create a composite key for all fields. Note: make sure to use a delimiter.


  1;Towney;Research and Development


Private Function getKey(ByVal rowIndex As Long, ByRef Target As Range) As String
    getKey = Target.Cells(rowIndex, 1) &amp; ";" &amp; Target.Cells(rowIndex, 2) &amp; ";" &amp; Target.Cells(rowIndex, 3)
End Function


SQL Solution

As Ryan Wildry stated "Using SQL is great for these type of set based comparisons." but this can be a little tricky.  The way I did it is I pasted my datasets into an Access Database as tables and use the Query Designer to help me write the code.


SELECT Dump.ID, Dump.Name, Dump.Department, "Item found in ""Dump"" but not in ""Active Directory""" AS [Found]
FROM Dump
WHERE (((Exists (SELECT NULL
  FROM [Active Directory]
  WHERE ([Active Directory].ID = Dump.ID) AND ([Active Directory].Name = Dump.Name) AND ([Active Directory].Department = Dump.Department)
))=False));
UNION ALL SELECT [Active Directory].ID, [Active Directory].Name, [Active Directory].Department, "Item found in ""Active Directory"" but not in ""[Active Directory]""" AS [Found]
FROM [Active Directory]
WHERE (((Exists (SELECT NULL
  FROM [Dump]
  WHERE ([Active Directory].ID = Dump.ID) AND ([Active Directory].Name = Dump.Name) AND ([Active Directory].Department = Dump.Department)
))=False));



I then aliased the tables to make it easier to replace the table names with the Excel Table Definition.


 SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Dump" but not in "Active Directory"' AS [Found]
 FROM [Dump$B4:E23] As t1
 WHERE (((Exists (SELECT NULL
   FROM [Active Directory] As t2
   WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
 ))=False))
 UNION ALL
 SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Active Directory" but not in "Dump"' AS [Found]
 FROM [Active Directory$B4:E20] As t1
 WHERE (((Exists (SELECT NULL
   FROM [Dump] As t2
   WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
 ))=False))



Now that I had the SQL working, I replaced the messages and created a single Select statement that I could modify to handle both selecting record in Dump and not in Active Directory or selecting records in Active Directory that are not in Dump.


SELECT t1.ID, t1.Name, t1.Department, "Message" AS [Found]
FROM [Dump] As t1
WHERE (((Exists (SELECT NULL
  FROM [Active Directory] As t2
  WHERE (t2.ID = t1.ID) AND (t2.Name = t1.Name) AND (t2.Department = t1.Department)
))=False));



Sub FindUnmatchedRowsCopyFromRecordset()

Create a recordset and use Range.CopyFromRecordset to transfer the records.

Sample SQl:


SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Dump" but not in "Active Directory"' AS [Found]
FROM [Dump$B4:E23] As t1
WHERE (((Exists (SELECT NULL
  FROM [Active Directory$B4:E20] As t2
  WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
))=False))
UNION ALL
SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Active Directory" but not in "Dump"' AS [Found]
FROM [Active Directory$B4:E20] As t1
WHERE (((Exists (SELECT NULL
  FROM [Dump$B4:E23] As t2
  WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
))=False))



Sub FindUnmatchedRowsAppend()

This is a slightly more complicated technique that appends the records directly to the Output tab.

Sample SQl:


INSERT INTO [Output$B4:E4] SELECT t3.* FROM (SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Dump" but not in "Active Directory"' AS [Found]
FROM [Dump$B4:E23] As t1
WHERE (((Exists (SELECT NULL
  FROM [Active Directory$B4:E20] As t2
  WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
))=False))
UNION ALL
SELECT t1.Name, t1.ID,  t1.Department, 'Item found in "Active Directory" but not in "Dump"' AS [Found]
FROM [Active Directory$B4:E20] As t1
WHERE (((Exists (SELECT NULL
  FROM [Dump$B4:E23] As t2
  WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)
))=False))) as t3



Code

Option Explicit

Sub FindUnmatchedRowsAppend()
    Dim conn As Object
    Set conn = getThisWorkbookConnection
    conn.Open

    DeleteOutputResults
    Dim OutputDef As String
    OutputDef = getTableDefinition(wsOutput)

    Dim SQL As String
    SQL = "INSERT INTO " &amp; OutputDef &amp; " SELECT t3.* FROM (" &amp; getOutputResultQuery &amp; ") as t3"

    conn.Execute SQL
    conn.Close
End Sub

Public Sub FindUnmatchedRowsCopyFromRecordset()
    Dim conn As Object
    Set conn = getThisWorkbookConnection
    conn.Open
    Dim SQL As String
    SQL = getOutputResultQuery

    Dim rs As Object
    Set rs = conn.Execute(SQL)

    DeleteOutputResults
    wsOutput.Range("B5").CopyFromRecordset rs

    conn.Close

End Sub

Private Function getOutputResultQuery() As String
    Dim ActiveDirectoryDef As String
    ActiveDirectoryDef = getTableDefinition(wsActiveDirectory)

    Dim DumpDef As String
    DumpDef = getTableDefinition(wsDump)

    Const BaseSQl As String = "SELECT t1.Name, t1.ID,  t1.Department, '@Message' AS [Found]" &amp; vbNewLine &amp; _
        "FROM [xlTable1] As t1" &amp; vbNewLine &amp; _
        "WHERE (((Exists (SELECT NULL" &amp; vbNewLine &amp; _
        "  FROM [xlTable2] As t2" &amp; vbNewLine &amp; _
        "  WHERE (t2.ID = t1.ID) And (t2.Name = t1.Name) And (t2.Department = t1.Department)" &amp; vbNewLine &amp; _
        "))=False))"

    Dim SelectDump As String
    SelectDump = Replace(BaseSQl, "[xlTable1]", DumpDef)
    SelectDump = Replace(SelectDump, "[xlTable2]", ActiveDirectoryDef)
    SelectDump = Replace(SelectDump, "@Message", "Item found in ""Dump"" but not in ""Active Directory""")

    Dim SelectAD As String
    SelectAD = Replace(BaseSQl, "[xlTable1]", ActiveDirectoryDef)
    SelectAD = Replace(SelectAD, "[xlTable2]", DumpDef)
    SelectAD = Replace(SelectAD, "@Message", "Item found in ""Active Directory"" but not in ""Dump""")

    Dim SQL As String
    SQL = SelectDump &amp; vbNewLine &amp; "UNION ALL" &amp; vbNewLine &amp; SelectAD

    getOutputResultQuery = SQL
End Function

Private Sub DeleteOutputResults()
    Dim Target As Range
    With wsOutput
        Set Target = .Range("B4:E4", .Cells(.Rows.Count, "B").End(xlUp))
        Target.Offset(1).ClearContents
    End With
End Sub

Private Function getTableDefinition(ws As Worksheet) As String
    Dim Target As Range
    Select Case ws.Name
        Case wsActiveDirectory.Name, wsDump.Name
            With ws
                Set Target = .Range("B4:E4", .Cells(.Rows.Count, "B").End(xlUp))
            End With
            If ws Is wsActiveDirectory Then
                Rem Remove Summary Row
                Set Target = Target.Resize(Target.Rows.Count - 1)
            End If
        Case wsOutput.Name
            With ws
                Set Target = .Range("B4:E4", .Cells(.Rows.Count, "B").End(xlUp))
            End With
    End Select

    getTableDefinition = getTableDefinitionFromRange(Target)
End Function

Private Function getThisWorkbookConnection() As Object
    Dim conn As Object
    Set conn = CreateObject("ADODB.Connection")
    With conn
       .Provider = "Microsoft.ACE.OLEDB.12.0"
       .ConnectionString = "Data Source=" &amp; ThisWorkbook.FullName &amp; ";" &amp; _
       "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    End With

    Set getThisWorkbookConnection = conn
End Function

Private Function getTableDefinitionFromRange(Target As Range) As String
    Dim SheetName As String
    SheetName = Target.Parent.Name
    Dim Address As String
    Address = Target.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    getTableDefinitionFromRange = "[" &amp; SheetName &amp; "$" &amp; Address &amp; "]"
End Function


Download Link

ADDump.xlsm