Copying from sheet to sheet if column headings match

Question

Basically, I have three sheets in my workbook where only the second and third worksheets are being used. I want to copy columns from the second sheet to the third sheet only if the column headings match. For example, the code will check the first row of sheet2 to check if it matches any of strings in an array and if it matches, it will copy the entire column to the third sheet under the same heading.

This code takes too long to process and I would like to make it faster.

Sub Standardization()

Dim myHeaders, e, x, wsImport As Worksheet, wsMain As Worksheet
Dim r As Range, c As Range

myHeaders = Array(
Array("Account_ID", "Account_ID"), Array("Claim_ID", "Claim_ID"), Array("Account_Name", "Account_Name"), _
Array("Claim_Type", "Claim_Type"), Array("Coverage", "Coverage"), Array("Claim_Level", "Claim_Level"), Array("Claim_Count", "Claim_Count"), _
Array("File_Date", "File_Date"), Array("File_Year", "File_Year"), Array("Resolution_Date", "Resolution_Date"), _
Array("Resolution_Year", "Resolution_Year"), Array("Claim_Status", "Claim_Status"), Array("Indemnity_Paid", "Indemnity_Paid"), _
Array("Disease_Category", "Disease_Category"), Array("State_Filed", "State_Filed"), Array("First_Exposure_Date", "First_Exposure_Date"), _
Array("Last_Exposure_Date", "Last_Exposure_Date"), Array("Claimant_Employee", "Claimant_Employee"), Array("Claimant_DOB", "Claimant_DOB"), _
Array("Claimant_Deceased", "Claimant_Deceased"), Array("Claimant_DOD", "Claimant_DOD"), Array("Claimant_Diagnosis_Date", "Claimant_Diagnosis_Date"), _
Array("Product_Type", "Product_Type"), Array("Product_Line", "Product_Line"), Array("Company/Entity/PC", "Company/Entity/PC"), _
Array("Plaintiff_Law_Firm", "Plaintiff_Law_Firm"), Array("Asbestos_Type", "Asbestos_Type"), Array("Evaluation_Date", "Evaluation_Date"), _
Array("Tier", "Tier"), Array("Data_Source", "Data_Source"), Array("Data_Source_Category", "Data_Source_Category"), _
Array("Jurisdiction/County", "Jurisdiction/County"), Array("Settlement_Demand", "Settlement_Demand"), Array("Jury_Verdict", "Jury_Verdict"), _
Array("Exposure_Site", "Exposure_Site"), Array("National_Defendant_Firm", "National_Defendant_Firm"), Array("Local_Defendant_Firm", "Local_Defendant_Firm"), _
Array("Expense_Amount", "Expense_Amount"), Array("NCC_Expense_Amount", "NCC_Expense_Amount"), Array("Non_NCC_Expense_Amount", "Non_NCC_Expense_Amount"))

Set wsImport = ThisWorkbook.Sheets(2)
Set wsMain = ThisWorkbook.Sheets(3)

Application.ScreenUpdating = False

For Each e In myHeaders
Set r = wsImport.Cells.Find(e(0), , , xlWhole)

If Not r Is Nothing Then
    Set c = wsMain.Cells.Find(e(1), , , xlWhole)

    If Not c Is Nothing Then
        wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
        wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
    Else
        msg = msg & vbLf & e(1) & " " & wsMain.Name
    End If
Else
    msg = msg & vbLf & e(0) & " " & wsImport.Name
End If

Next

Application.ScreenUpdating = False
wsMain.Columns("A:AO").Select
Selection.EntireColumn.AutoFit

Application.ScreenUpdating = False
Selection.ClearFormats

Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
tbl.TableStyle = "TableStyleMedium9"

Application.ScreenUpdating = True

End Sub

Answer 1

Okay. So, let's start with this gigantic array of arrays you've got there. I don't mean to be rude, but what exactly are you doing here?! Each and every one of the inner arrays simply duplicates itself. For the life of me I can't figure out why you have it duplicated. This would work just as well by adding each of these strings to a collection. I would create a single function that intializes and returns this collection.

Private Function GetHeaders() As Collection
    Dim result As New Collection
    With result
        .Add "Account_ID"
        .Add "Claim_ID"
        .Add "Account_Name"
        ' ...
    End With

    Set GetHeaders = result
End Function

And call it at the beginning of Standardization like this.

Dim headers As Collection
Set headers = GetHeaders

Which turns your loop into this.

Dim header As Variant
For Each header In myHeaders
    Set r = wsImport.Cells.Find(header, , , xlWhole)

    If Not r Is Nothing Then
        Set c = wsMain.Cells.Find(header, , , xlWhole)

        If Not c Is Nothing Then
            wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
            wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
        Else
            msg = msg & vbLf & header & " " & wsMain.Name
        End If
    Else
        msg = msg & vbLf & header & " " & wsImport.Name
    End If

Next

Note that I added a level of indentation inside of the loop, and replaced the cryptic e variable with the more sensible and descriptive header variable.

Now the duplication becomes so obvious that it's painful, so let's extract a couple more functions.

Private Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range
    Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)
End Function

and

Private Function BuildMessage(ByVal currentMessage As String, ByVal ws As Worksheet, ByVal header As String) As String
    BuildMessage = currentMessage & vbLf & header & Space(1) & ws.Name
End Function

Note that I replaced the literal space with a call to Space(1). This is just for readability. It's much easier to parse the function call than a " ".

Also, you never defined msg in your original code. Turn Option Explicit on so this doesn't happen in the future. It helps turn runtime errors into compile time errors. It's kind of magical. You should always be using it.

Anyway, I took the liberty of renaming some more cryptic variables, and now it looks like this.

Dim header As Variant
Dim source As Range
Dim dest As Range
For Each header In headers
    Set source = FindHeaderRange(wsImport, header)

    If Not source Is Nothing Then
        Set dest = FindHeaderRange(wsMain, header)

        If Not dest Is Nothing Then
            wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _
                wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2)
        Else
            msg = BuildMessage(msg, wsMain, header)
        End If
    Else
        msg = BuildMessage(msg, wsImport, header)
    End If

Next

Which is better, but I'd prefer to take a happy path whenever possible. It's easier to reason about positive statements than double negatives.

For Each header In headers

    Set source = FindHeaderRange(wsImport, header)
    If source Is Nothing Then
        msg = BuildMessage(msg, wsImport, header)
    Else

        Set dest = FindHeaderRange(wsMain, header)
        If dest Is Nothing Then
            msg = BuildMessage(msg, wsMain, header)
        Else
            wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _
                wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2)
        End If
    End If
Next

---

• You don't ever use the variable x. Get rid of it entirely.
• You turn screen updating off three times without ever turning it back on. Once is enough.
• Speaking of screen updating, anytime you turn it off, you need an error handler to ensure it always gets turned back on no matter what happens while the code is executing.

• Don't activate and select. Use object references/variables instead.

  wsMain.Columns("A:AO").Select
  Selection.EntireColumn.AutoFit
  Selection.ClearFormats
  
  Dim tbl As ListObject
  Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
  

  Should be

     Dim cols As Range
     Set cols = wsMain.Columns("A:AO") 
     cols.EntireColumn.AutoFit
     cols.ClearFormats
  
     Dim tbl As ListObject
     Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, cols, , xlYes)
     tbl.TableStyle = "TableStyleMedium9"
  

• Always be explicit about scope. Procedures defined as just plain Sub are public. It's better to write that down instead of relying on a developer's knowledge (or lack there of).

Here's the resulting code. I apologize that I never got around to performance. There were a number of issues to work through first. If I get time, I'll take a look at the performance later.

Public Sub Standardization()
On Error GoTo ExitSub

    Dim headers As Collection
    Set headers = GetHeaders

    Dim msg As String

    Dim wsImport As Worksheet, wsMain As Worksheet

    Set wsImport = ThisWorkbook.Sheets(2)
    Set wsMain = ThisWorkbook.Sheets(3)

    Application.ScreenUpdating = False

    Dim header As Variant
    Dim source As Range
    Dim dest As Range
    For Each header In headers

        Set source = FindHeaderRange(wsImport, header)
        If source Is Nothing Then
            msg = BuildMessage(msg, wsImport, header)
        Else

            Set dest = FindHeaderRange(wsMain, header)
            If dest Is Nothing Then
                msg = BuildMessage(msg, wsMain, header)
            Else
                wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _
                    wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2)
            End If
        End If
    Next

    Dim cols As Range
    Set cols = wsMain.Columns("A:AO")
    cols.EntireColumn.AutoFit
    cols.ClearFormats

    Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, cols, , xlYes)
    tbl.TableStyle = "TableStyleMedium9"

ExitSub:
    Application.ScreenUpdating = True

End Sub

Answer 2

This answer is based on the answer provided by @Rubberduck and it should give you some performance improvements.

Firstly, if you source data is "rectangular" (i.e. all columns are the same length) then the bits of code that work out how many rows to copy and which row into paste them can be done just once before you begin the loop that looks for the headers.

I ran some timings using test data and the slowest part of the code is the copy & paste so if we can improve this we should see large improvements. At the moment your code assumes that there is no grouping of columns so they all get copied singly. When the code has found a matching header, it could then check the adjacent headings in the sheets to see if they match. If there are additional matches then the code can copy more than the one column at a time. If we change the headers variable from a Collection into a Dictionary we can keep track of which columns have been copied.

The GetHeaders function has been changed to return a dictionary where the key is the header text and the value will be True/False to show whether this heading has been found and copied. To use the Scripting.Dictionary in your code, from the VBA IDE select Tools -> References and then find and check the entry for "Microsoft Scripting Runtime". Here is the function.

Private Function GetHeadersDict() As Scripting.Dictionary

Dim result As Scripting.Dictionary

    Set result = New Scripting.Dictionary

    With result
        .Add "Account_ID", False
        .Add "Claim_ID", False
        .Add "Account_Name", False
        .Add "Claim_Type", False
        .Add "Coverage", False
        .Add "Claim_Level", False
        .Add "Claim_Count", False
        .Add "File_Date", False
        .Add "File_Year", False
        .Add "Resolution_Date", False
        .Add "Resolution_Year", False
        .Add "Claim_Status", False
        .Add "Indemnity_Paid", False
        .Add "Disease_Category", False
        .Add "State_Filed", False
        .Add "First_Exposure_Date", False
        .Add "Last_Exposure_Date", False
        .Add "Claimant_Employee", False
        .Add "Claimant_DOB", False
        .Add "Claimant_Deceased", False
        .Add "Claimant_DOD", False
        .Add "Claimant_Diagnosis_Date", False
        .Add "Product_Type", False
        .Add "Product_Line", False
        .Add "Company/Entity/PC", False
        .Add "Plaintiff_Law_Firm", False
        .Add "Asbestos_Type", False
        .Add "Evaluation_Date", False
        .Add "Tier", False
        .Add "Data_Source", False
        .Add "Data_Source_Category", False
        .Add "Jurisdiction/County", False
        .Add "Settlement_Demand", False
        .Add "Jury_Verdict", False
        .Add "Exposure_Site", False
        .Add "National_Defendant_Firm", False
        .Add "Local_Defendant_Firm", False
        .Add "Expense_Amount", False
        .Add "NCC_Expense_Amount", False
        .Add "Non_NCC_Expense_Amount", False
    End With

    Set GetHeadersDict = result
End Function

The Standardization proc has been changed so it loops through the keys of the dictionary. If the value of the key is False then it looks for the heading value in both sheets. If found, it then checks the adjacent columns to see if both sheets match. If they match, the relevant entry in the dictionary has its value set to True because it will get copied. The code then copies the relevant number of columns.

If you are using the msg variable, after the code has created the data table it can loop through the dictionary again, looking for those keys with a value of False. These are the headings that were not copied across.

The error handling has also been slightly improved so that any error gets displayed to you.

Calculations are also set to manual and then back to automatic.

The improvement that you will get from this code depends on how the columns in your source are grouped & ordered.

Public Sub Standardization()

On Error GoTo ErrorMessage

Dim headersDict As Scripting.Dictionary
Dim msg As String
Dim dictKey As Variant
Dim header As String
Dim source As Range
Dim dest As Range
Dim wsImport As Worksheet, wsMain As Worksheet
Dim numRowsToCopy As Long
Dim destRowOffset As Long
Dim numColumnsToCopy As Long

    Set headersDict = GetHeadersDict()

    Set wsImport = ThisWorkbook.Sheets(2)
    Set wsMain = ThisWorkbook.Sheets(3)

    numRowsToCopy = wsImport.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row - 1
    destRowOffset = wsMain.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For Each dictKey In headersDict
        header = CStr(dictKey)
        If headersDict.Item(header) = False Then
            Set source = FindHeaderRange(wsImport, header)
            If Not (source Is Nothing) Then
                Set dest = FindHeaderRange(wsMain, header)
                If Not (dest Is Nothing) Then
                    headersDict.Item(header) = True
                    ' Look at successive headers to see if they match
                    ' If so, can copy these columns altogether which
                    ' will be quicker
                    For numColumnsToCopy = 1 To headersDict.Count
                        If source.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
                            headersDict.Item(CStr(source.Offset(ColumnOffset:=numColumnsToCopy).Value)) = True
                        Else
                            Exit For
                        End If
                    Next numColumnsToCopy

                    source.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
                        dest.Offset(RowOffset:=destRowOffset)
                End If
            End If
        End If
    Next dictKey

    Dim cols As Range
    Set cols = wsMain.Columns("A:AO")
    cols.EntireColumn.AutoFit
    cols.ClearFormats

    Dim tbl As ListObject
    Set tbl = wsMain.ListObjects.Add(xlSrcRange, cols, , xlYes)
    tbl.TableStyle = "TableStyleMedium9"

    For Each dictKey In headersDict
        header = CStr(dictKey)
        If headersDict.Item(header) = False Then
            msg = msg & vbNewLine & header
        End If
    Next dictKey

ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    If msg <> "" Then
        MsgBox "The following headers were not copied:" & vbNewLine & msg
    End If
Exit Sub

ErrorMessage:
    MsgBox "An error has occurred: " & Err.Description
    Resume ExitSub

End Sub