macro to copy and paste data from one Sheet to another when Header is matching

hassan786

New Member
Joined
Apr 8, 2019
Messages
3
Hello Sir,

I am trying to create a macro to copy and paste data from one Sheet to another sheet when Header and Column A data is matching and want to paste into the specific cell.

below code is working fine for me when Row(headers) order is the same in both sheets. but I need a solution for when the row (Headers) are not in the order.

"I hope I was able to explain my problem"

Code:
Sub transfer()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
lastrow1 = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To lastrow1
myname = Sheets("sheet1").Cells(i, "A").Value


Sheets("sheet2").Activate
lastrow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row


For j = 2 To lastrow2


If Sheets("sheet2").Cells(j, "A").Value = myname Then
Sheets("sheet1").Activate
Sheets("sheet1").Range(Cells(i, "B"), Cells(i, "F")).Copy
Sheets("sheet2").Activate
Sheets("sheet2").Range(Cells(j, "D"), Cells(j, "H")).Select
ActiveSheet.Paste
End If


Next j
Application.CutCopyMode = False
Next i
Sheets("sheet1").Activate
Sheets("sheet1").Range("A1").Select




End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Hi hassan786,

One way is to create a translation column of each columns.

I think the vba code below could do what you ask. It will work whatever the order of columns. You might what to trap the code for errors if columns aren't found.

Don't forget to Thanks / Like if it does what you require.

Good luck and enjoy

Code:
Sub createTranslation()    

    Dim ws1                 As Worksheet
    Dim ws2                 As Worksheet
    Dim lngColTrans()       As Long                     'translation column
    
    Dim lng1NoCols          As Long
    Dim lng2NoCols          As Long
    Dim lng1MaxRow          As Long
    Dim lng2MaxRow          As Long
    
    Dim i                   As Long
    Dim cell                As Range
    Dim lCol                As Long
    Dim lRow                As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")


    lng1NoCols = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    lng2NoCols = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column


    If lng1NoCols <> lng2NoCols Then Exit Sub                   'must have same number of columns


    lng1MaxRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    lng1MaxRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row


    'create translation table
    ReDim lngColTrans(1 To lng1NoCols)                          'create container to store translation columns
    For i = 2 To lng1NoCols
        lCol = Application.WorksheetFunction.Match(ws1.Cells(1, i), ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lng2NoCols)), 0)
        lngColTrans(i) = lCol
    Next i
' Translation table created


'now loop through each cell in sheet1 and update each cell in Sheet2


    For i = 2 To lng1MaxRow
    
        lRow = Application.WorksheetFunction.Match(ws1.Cells(i, 1), ws2.Range(ws2.Cells(1, 1), ws2.Cells(lng1MaxRow, 1)), 0)


        For j = 2 To lng1NoCols
            ws2.Cells(lRow, lngColTrans(j)) = ws1.Cells(i, j)
        Next j


    Next i


' Clear existing references
    Set ws1 = Nothing
    Set ws2 = Nothing
    Erase lngColTrans
End Sub
 
Last edited:
Upvote 0
it would help if you could provide snapshots of the the data arrangement (worksheet ) for both situations - when the code works and when it does not.
 
Upvote 0
Hi Hassan786,

Having seen your screen shot I can't see why the VBA code above should not work.

Rules.

1) Make sure that column "A" is the same on both sheets
2) Make sure same headers are on both sheets
3) Best before running macro you should delete clear all cells in range "B2:{Last Cell in data} on sheet2. (Just keep headers and Column "A")
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top