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. Since ANGULAR brackets like 'greater than' and 'less than' are not permitted I'm using 'NOT EQUAL TO' in the 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 Not Equal To "" 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

Видео Copy Multiple Columns Data from Worksheet to Worksheet канала Dinesh Kumar Takyar