# 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

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

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

• Welcome to Code Review! I'm sure there are ways this can be improved; I hope you get some good answers from our VBA pros! Jun 1 '15 at 15:48
• It might help if you can describe a little more in plain english what this code does. Jun 1 '15 at 15:50
• 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. Jun 1 '15 at 15:55
• @BLkrn I have added this detail into your question, thanks for explaining Jun 1 '15 at 16:06
• Can you clarify why you have the long list of strings? Your description says that you are matching column headings from the second sheet with those in the third sheet, so can I replace the array (collection in rubberduck's answer) of string values with code that reads from the second sheet? Jun 14 '15 at 10:14

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
' ...
End With

End Function


And call it at the beginning of Standardization like this.

Dim headers As Collection


Which turns your loop into this.

Dim header As Variant
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
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

If Not source Is Nothing Then

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
End If
Else
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

If source Is Nothing Then
Else

If dest Is Nothing Then
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 msg As String

Dim wsImport As Worksheet, wsMain As Worksheet

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

Application.ScreenUpdating = False

Dim source As Range
Dim dest As Range

If source Is Nothing Then
Else

If dest Is Nothing Then
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

• Thank you so much for your help! I was wondering, if it is possible to make this code more efficient in terms of time, for one circulation takes about 20 seconds in total per file. Jun 2 '15 at 14:58

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
End With

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 msg As String
Dim dictKey As Variant
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 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

If Not (source Is Nothing) Then
If Not (dest Is Nothing) Then
' 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
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"

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