Copying from sheet to sheet if column headings match

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 

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