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

[hassan786]

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"

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

 

[Brombrough]

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

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

 

[ravisingh]

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.

 

[hassan786]

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.

here is the link thanks
https://drive.google.com/open?id=1RGCd7EDMWPRC4e7Tw_u4NiIJ7zkzGyOL
https://drive.google.com/open?id=1DOrC_hvaPz50n3YBKwlt7HIyhJxQchHQ

 

[hassan786]

Thank you I did not try yet. I will try and let you know. Below is the links for the PIC

https://drive.google.com/open?id=1DOrC_hvaPz50n3YBKwlt7HIyhJxQchHQ
https://drive.google.com/open?id=1RGCd7EDMWPRC4e7Tw_u4NiIJ7zkzGyOL

 

[Brombrough]

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