Excel macro to copy data matching column header between two OPEN WorkBooks

Question

I am looking for a macro to copy data matching column headers between two OPEN workbooks. I have below code to copy data between sheets in the same workbook. But I need as below to copy between TWO OPEN workbooks.

First open the Destination Workbook (Have a macro button in it to copy data)
Second open source workbook (to physically see and verify data)
Third, go to destination workbook and click button to copy.

Can anyone please help me.

Sub CopyMatchingHeaders()

Dim wbSource As Workbook
Dim SFileName As Variant

SFileName = Application.GetOpenFilename("Excel Files, *.xlsx, *.xls*,", MultiSelect:=False)

If TypeName(SFileName) = "String" Then
    Set wbSource = Workbooks.Open(SFileName)
Else
    MsgBox "No file selected."
    Exit Sub
End If


Dim header As Range, headers As Range
Set headers = ActiveWorkbook.Worksheets("Sheet1").Range("A1:AE1")

For Each header In headers
    If GetHeaderColumn(header.Value) > 0 Then
        Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=ActiveWorkbook.Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))
    End If
Next

End Sub

Function GetHeaderColumn(header As String) As Integer
  Dim headers As Range
  Set headers = ActiveWorkbook.Worksheets("Sheet2").Range("A1:AE1")
  GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Have you tried anything to do what you want to do? If so, please update the question to show what you have tried and tell us which bit didn't work as expected. — YowE3K
I tried the above updated code, it works fine. But this code opens the source file and copy data in one go. I need seperate macro buttons to open the file first and then copy data. I have code to open the source file but from there i need code to copy data. Thanks — Siraj

A.S.H A.S.H · Accepted Answer · 2017-04-24T11:58:37

You may try to modify these statements:

Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=ActiveWorkbook.Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))
'                                                                ^^^^^^^^^^^^^^

and

Set headers = ActiveWorkbook.Worksheets("Sheet2").Range("A1:AE1")
'             ^^^^^^^^^^^^^^

Replace ActiveWorkbook by something like:

Workbooks("TheOtherWorkbookName")

The name of your destination worksheet may also be different that "Sheet2".

Excel macro to copy data matching column header between two OPEN WorkBooks

1 Answers