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

[Orxan]

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.

 

[mumps]

Place this macro in workbook A. Change the destination workbook name (in red) and the sheet names (in blue) to suit your needs.

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

 

[Orxan]

Place this macro in workbook A. Change the destination workbook name (in red) and the sheet names (in blue) to suit your needs.

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.

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.

 

[mumps]

Try:

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

 

[Orxan]

T

Try:

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.

 

[mumps]

You are very welcome.