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