VBA code for copy paste data based on column headers.

Balajibenz

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows
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.
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,774
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I change Macro for Yours:
Change Workbook name and Sheet name to yours.
VBA Code:
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
 
Solution

Balajibenz

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

I change Macro for Yours:
Change Workbook name and Sheet name to yours.
VBA Code:
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

Well-known Member
Joined
Oct 22, 2012
Messages
1,774
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
What is your Excel file name & sheets Exactly?
AND are Extention of Both is .xlsm or different?
 

Balajibenz

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Oct 22, 2012
Messages
1,774
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
change that lines to if your Source File is "Offshore.xlsx"
VBA Code:
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"

VBA Code:
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

Board Regular
Joined
Nov 18, 2020
Messages
56
Office Version
  1. 2013
Platform
  1. Windows
change that lines to if your Source File is "Offshore.xlsx"
VBA Code:
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"

VBA Code:
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

Well-known Member
Joined
Oct 22, 2012
Messages
1,774
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
You're Welcome & Thanks for Feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,383
Messages
5,635,942
Members
416,889
Latest member
dhegs

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
Top