Copy/Paste values from a workbook to another one based on column header

Orxan

New Member
Joined
Oct 1, 2019
Messages
7
Hello Everyone,

I would appreciate if anyone can help/share (code with) me to solve repetitive excel task.
I have two different files A & B. I would like to copy/paste values from A to B based on columns headers.
File A is taken from system and each time sequence of the column headers are changing. Both files have identical headers but different sequence and the file contains more than 70 headers.
I want to find out how to copy the entire values from the file A to the file B based on the header.




1611585918122.png
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Place this macro in workbook A. Change the destination workbook name (in red) and the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, srcWS As Worksheet, lCol As Long, x As Long, header As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("B.xlsx").Sheets("Sheet1")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            Set header = desWS.Rows(1).Find(.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not header Is Nothing Then
                .Range(.Cells(2, x), .Cells(LastRow, x)).Copy desWS.Cells(desWS.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Place this macro in workbook A. Change the destination workbook name (in red) and the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, srcWS As Worksheet, lCol As Long, x As Long, header As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("B.xlsx").Sheets("Sheet1")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            Set header = desWS.Rows(1).Find(.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not header Is Nothing Then
                .Range(.Cells(2, x), .Cells(LastRow, x)).Copy desWS.Cells(desWS.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub

Place this macro in workbook A. Change the destination workbook name (in red) and the sheet names (in blue) to suit your needs.
Rich (BB code):
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, srcWS As Worksheet, lCol As Long, x As Long, header As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("B.xlsx").Sheets("Sheet1")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            Set header = desWS.Rows(1).Find(.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not header Is Nothing Then
                .Range(.Cells(2, x), .Cells(LastRow, x)).Copy desWS.Cells(desWS.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub
Hello,

Thank you very much for your help.

Is it possible to modify this code? My idea is to run this code in my main workbook (workbook B) where I have to store data from file A. With the help of GetOpenFilen (file A) and copy values based on column headers.

Thank you in advance.
 
Upvote 0
Try:
VBA Code:
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, srcWB As Workbook, lCol As Long, x As Long, header As Range
    Dim flder As FileDialog, FileName As String, FileChosen As Integer
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    With flder
        .Title = "Please Select an Excel File"
        .Filters.Add "Excel Macros Files", "*.xls*"
        FileChosen = .Show
        FileName = .SelectedItems(1)
    End With
    Set srcWB = Workbooks.Open(FileName)
    With Sheets("Sheet1")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            Set header = desWS.Rows(1).Find(.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not header Is Nothing Then
                .Range(.Cells(2, x), .Cells(LastRow, x)).Copy desWS.Cells(desWS.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
T
Try:
VBA Code:
Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, desWS As Worksheet, srcWB As Workbook, lCol As Long, x As Long, header As Range
    Dim flder As FileDialog, FileName As String, FileChosen As Integer
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    With flder
        .Title = "Please Select an Excel File"
        .Filters.Add "Excel Macros Files", "*.xls*"
        FileChosen = .Show
        FileName = .SelectedItems(1)
    End With
    Set srcWB = Workbooks.Open(FileName)
    With Sheets("Sheet1")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To lCol
            Set header = desWS.Rows(1).Find(.Cells(1, x).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not header Is Nothing Then
                .Range(.Cells(2, x), .Cells(LastRow, x)).Copy desWS.Cells(desWS.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
            End If
        Next x
    End With
    Application.ScreenUpdating = True
End Sub
Hello,

It works perfectly. Thank you very much! Much appreciated.
 
Upvote 0

Forum statistics

Threads
1,223,243
Messages
6,170,967
Members
452,371
Latest member
Frana

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