Copying from sheet to sheet if column headings match

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

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 performanc

StackExchange Code Review Q#92376, answer score: 5