September 26, 2019

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()


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”)


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

Exit For
End If

Next numColumnsToCopy

source.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
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

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

If msg <> “” Then
MsgBox “The following headers were not copied:” & vbNewLine & msg
End If
Exit Sub

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

6 thoughts 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.

    Thank you!

  2. Hi Dinesh,

    I’ve tried you formula but somehow it isn’t working.

    Can you please help me to take a look at it? I followed it step by step

  3. Hello Dinesh,

    My code below copies only last row 31 times in Sheet3. I want to copy from row 1 to 31 from sheet 1(col A,B) and sheet2(col A,B) to sheet 3 ( Col A,B,C,D) as described in the code. If i dont have i loop it will copy only last row ๐Ÿ™

    Kindly help – bit urgent! Thanks a ton…

    Sub populate()
    Dim lastrow As Long
    Dim erow As Long

    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastrow

    erow = Sheet3.Cells(1, 1).CurrentRegion.Rows.Count + 1
    Sheet3.Cells(erow, 1) = Sheet1.Cells(lastrow, 1)
    Sheet3.Cells(erow, 2) = Sheet1.Cells(lastrow, 2)

    erow = Sheet3.Cells(1, 1).CurrentRegion.Rows.Count
    Sheet3.Cells(erow, 3) = Sheet2.Cells(lastrow, 1)
    Sheet3.Cells(erow, 4) = Sheet2.Cells(lastrow, 2)

    Application.CutCopyMode = False

    End Sub

  4. Hello guys, my name is Kyran Mckinney!

    I`m a professional writer and I`m going to change your lifes onัe and for all
    Writing has been my passion for a long time and now I cannot imagine my life without it.
    Most of my works were sold throughout Canada, USA, Old England and even Russia. Also I`m working with services that help people to save their time.
    People ask me “Mr, Kyran, I need your professional help” and I always accept the request, `cause I know, that only I can save their time!

    Professional Writer – Kyran Mckinney – Killer Papers Corp

  5. My name is Cavan. And I am a professional Content writer with many years of experience in writing.

    My primary goal is to solve problems related to writing. And I have been doing it for many years. I have been with several groups as a volunteer and have assisted clients in many ways.
    My love for writing has no end. It is like the air we breathe, something I cherish with all my being. I am a full-time writer who started at an early age.
    Iโ€™m happy that I`ve already sold several copies of my poems in different countries like England and others too numerous to mention.
    I also work in an organization that provides assistance to many students from different parts of the world. Clients always come to me because I work no matter how difficult their projects are. I help them to save time, because I feel fulfilled when people come to me for professional help.

    Professional academic Writer โ€“ Cavan – Help Norway to Save Its ForestsCompany

  6. Hi and welcome to my blog . Iโ€™m Leonard Rossi.
    I have always dreamed of being a novelist but never dreamed Iโ€™d make a career of it. In college, though, I aided a fellow student who needed help. She could not stop complimenting me . Word got around and someone asked me for to help them just a week later. This time they would pay me for my work.
    During the summer, I started doing research paper writing for students at the local college. It helped me have fun that summer and even funded some of my college tuition. Today, I still offer my research paper writing to students.

    Writing Specialist โ€“ Leonard โ€“ Company

Comments are closed.