Copy Multiple Columns Data from Worksheet to Worksheet

How to copy multiple columns data from worksheet to worksheet automatically with VBA even when the position of the headers changes.
Here’s the complete code:
Option Explicit

Function GetHeadersDict() As Scripting.Dictionary
‘ We must activate the Microsoft Scripting Runtime from Tools –> References

Dim result As Scripting.Dictionary

Set result = New Scripting.Dictionary

With result

.Add “Name”, False
.Add “Mobile”, False
.Add “Phone”, False
.Add “City”, False
.Add “Designation”, False
.Add “DOB”, False

End With

Set GetHeadersDict = result

End Function

Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range

Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)

End Function

Sub clearDataSheet2()

Sheets(“Destination”).Range(“A1”).CurrentRegion.Offset(1).ClearContents

End Sub

Sub copyColumnData()

On Error GoTo ErrorMessage

Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets(“Source”)
Set ws2 = ThisWorkbook.Sheets(“Destination”)

clearDataSheet2

Dim numRowsToCopy As Long

numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row – 1
‘MsgBox “The no of rows to copy is ” & numRowsToCopy

Dim destRowOffset As Long

destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
‘MsgBox “The next Blank row is ” & destRowOffset

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim source As Range
Dim dest As Range

Dim headersDict As Scripting.Dictionary

Set headersDict = GetHeadersDict()

For Each dictKey In headersDict
header = dictKey
If headersDict.Item(header) = False Then
Set source = FindHeaderRange(ws1, header)
If Not (source Is Nothing) Then
Set dest = FindHeaderRange(ws2, header)
If Not (dest Is Nothing) Then
headersDict.Item(header) = True
‘ Look at successive headers to see if they match
‘ If so, copy these columns altogether to make the macro faster
For numColumnsToCopy = 1 To headersDict.Count
‘MsgBox numColumnsToCopy
If source.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
headersDict.Item(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 msg As String

For Each dictKey In headersDict
header = 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

Watch the video below:

Further reading:
Copying from Sheet to Sheet If Column headings match

Published by

Dinesh Kumar Takyar

Welcome to exceltrainingvideos.com! My aim is to help you learn MS Excel including VBA. I always felt that a good way to learn something was to find solutions to problems in that domain. That is why I share these Excel videos with you. Mostly these are questions asked during my corporate training sessions. I've been training individuals and companies in computers since 1991. I did my B. Sc. (Vordiplom), M. Sc. (Diplom) and Ph.D. (Dr. rer. nat.) from Hamburg, Germany. The best thing about solving some of my visitor's questions is that I also gain new insights. For more Excel VBA solutions you may like to visit my YouTube channel: http://youtube.com/familycomputerclub For a structured Excel VBA training course online you can visit: https://www.youtube.com/excelvbaonline

One thought on “Copy Multiple Columns Data from Worksheet to Worksheet”

  1. I am in need of some help. I have tried numerous times to get this to work. I need to copy specific cells and have the data paste in a seperate workbook. If you could email me then I could send you what I am trying to do.

    adamlemons92@gmail.com

    Thank you!

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.