VBA code for copy paste data based on column headers.

[Balajibenz]

Hi All,

Can someone help me with below requirement.

I have two wrokbooks wk1 and wk2 in the same path as my macro workbook. in Wk1 in sheet1 i have my dump from column A to AX.

in Wk2 in sheet2 i have headers from column A1 to S1 what i am looking for is to copy respective data for each header from sheet1(WK1) and paste it in sheet2(WK2).

Code has to basically look for each header in Sheet1(WK1) and copy the data untill last row (Column "A" last row should be the default reference for copying data). thank you in adavance.

 

[maabadi]

Please check Reply of this Post:
Macro to copy and paste based on column headings

 

[Balajibenz]

Hi

Please check Reply of this Post:
Macro to copy and paste based on column headings

Hi this article helps to copy paste for only one headers but I had to to repeat the same for all the headers from A to S1 in sheet2.

 

[maabadi]

I change Macro for Yours:
Change Workbook name and Sheet name to yours.

Public Sub CopyProjectName()
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim lastCol As Long, lastRow As Long, srcRow As Range
    Dim found1 As Range, found2 As Range, j As Long, Cr1 As String

    Set sourceWS = Workbooks("Workbook1.xlsm").Worksheets("Sheet1") 'Needs to be open
    Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet1") 'Needs to be open

    With sourceWS
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        For j = 1 To lastCol
        Cr1 = .Cells(1, j).Value
        Set srcRow = .Range("A1", .Cells(1, lastCol))
        Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

        If Not found1 Is Nothing Then
            lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
            Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
            Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

            If Not found2 Is Nothing Then
                lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
                .Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
                found2.Offset(1, 0).PasteSpecial xlPasteAll
            End If
        End If
      Next j
    End With
End Sub

 

[Balajibenz]

I change Macro for Yours:
Change Workbook name and Sheet name to yours.

Public Sub CopyProjectName()
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim lastCol As Long, lastRow As Long, srcRow As Range
    Dim found1 As Range, found2 As Range, j As Long, Cr1 As String

    Set sourceWS = Workbooks("Workbook1.xlsm").Worksheets("Sheet1") 'Needs to be open
    Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet1") 'Needs to be open

    With sourceWS
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        For j = 1 To lastCol
        Cr1 = .Cells(1, j).Value
        Set srcRow = .Range("A1", .Cells(1, lastCol))
        Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

        If Not found1 Is Nothing Then
            lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
            Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
            Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

            If Not found2 Is Nothing Then
                lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
                .Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
                found2.Offset(1, 0).PasteSpecial xlPasteAll
            End If
        End If
      Next j
    End With
End Sub

Hi Mate,

Though the workbooks are opened still I am getting error at below lines.

Set sourceWS = Workbooks("Workbook1.xlsm").Worksheets("Sheet1") 'Needs to be open
Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet1") 'Needs to be open.

can you help me with this.

 

[maabadi]

What is your Excel file name & sheets Exactly?
AND are Extention of Both is .xlsm or different?

 

[Balajibenz]

my excel files names are "offshore time" and "Raw Dump" and both are in xlsx. sheet names are "offshore data" and "Source"

What is your Excel file name & sheets Exactly?
AND are Extention of Both is .xlsm or different

 

[maabadi]

change that lines to if your Source File is "Offshore.xlsx"

Set sourceWS = Workbooks("Offshore.xlsx").Worksheets("Offshore Data") 'Needs to be open
Set targetWS = Workbooks("Raw Dump.xlsx").Worksheets("Source") 'Needs to be open.

AND if your Source File is "Raw Dump.xlsx"

Set sourceWS = Workbooks("Raw Dump.xlsx").Worksheets("Source") 'Needs to be open.
Set targetWS = Workbooks("Offshore.xlsx").Worksheets("Offshore Data") 'Needs to be open

 

[Balajibenz]

change that lines to if your Source File is "Offshore.xlsx"

Set sourceWS = Workbooks("Offshore.xlsx").Worksheets("Offshore Data") 'Needs to be open
Set targetWS = Workbooks("Raw Dump.xlsx").Worksheets("Source") 'Needs to be open.

AND if your Source File is "Raw Dump.xlsx"

Set sourceWS = Workbooks("Raw Dump.xlsx").Worksheets("Source") 'Needs to be open.
Set targetWS = Workbooks("Offshore.xlsx").Worksheets("Offshore Data") 'Needs to be open

hey mate, that worked perfectly. thank you so much.

It would be great if you could help me with my latest post - VBA code to re-arrange the data based on date and zone.

 

[maabadi]

You're Welcome & Thanks for Feedback.