How to get data from closed workbook based on headers

[Villalobos]

Hello,

I would need some help how to pull data into open workbook (Test2.xlsm) from closed workbook (Test1.xlsm) based on unique headers.

The Test1.xlsm contains that data what I would like to extract to Test2.xlsm (starting in A1) and these are that columns what should be presented in Test2.xlsm: "Material", "Stock", "Blocked" from Test1.xlsm. The extracted columns must be next to each other. And the code should extract the data until the "Lastrow" of "Material" (<- from Test1.xlsm).

This is the code what I use now (in Test2.xlsm) but it is just get the specific range instead of column headers.

Option Explicit
Sub GetDataDemo()
  Dim FilePath$, Row&, Column&, Address$

  Const FileName$ = "Test1.xlsm"
  Const SheetName$ = "Test1"
  Const NumRows& = 250
  Const NumColumns& = 250
  FilePath = ActiveWorkbook.Path & "\"

  
  DoEvents
  Application.ScreenUpdating = False
  If Dir(FilePath & FileName) = Empty Then
  MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
  Exit Sub
  End If
  For Row = 1 To NumRows
  For Column = 1 To NumColumns
  Address = Cells(Row, Column).Address
  Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
  Columns.AutoFit
  Next Column
  Next Row
  ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(Path, File, Sheet, Address)

  Dim Data$
  Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
  Range(Address).Range("A1").Address(, , xlR1C1)
  GetData = ExecuteExcel4Macro(Data)
End Function

I have attached the sample files with the expected result.
Could somebody give me some advice how to do it?

Thanks in advance the reply!

 

[Villalobos]

Admin!

Please, would you be so kind to move this thread to VBA Macros topic.

 

[Luke M]

Admin!

Please, would you be so kind to move this thread to VBA Macros topic.

Done

 

[Villalobos]

Hi,

Do you have any idea how to solve this problem?

 

[wudixin96]

Sub GetDataDemo()
      Dim FilePath$, Row&, Column&, Address$
      Dim conn As Object, strSql$
     
      Const FileName$ = "Test1.xlsm"
      Const SheetName$ = "Test1"
      Const myRange = "D1:I"
   
      FilePath = ActiveWorkbook.Path & "\"

     
     
      Application.ScreenUpdating = False
      If Dir(FilePath & FileName) = Empty Then
            MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
            Exit Sub
      End If
     
      Set conn = CreateObject("adodb.connection")
      conn.Open "Provider=Microsoft.Ace.oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & FilePath & FileName
      strSql = "Select Material,Stock,Blocked from [" & SheetName & "$" & myRange & "] Where Material is not null"
      [A2].CopyFromRecordset conn.Execute(strSql)
      conn.Close
      Set conn = Nothing
      ActiveWindow.DisplayZeros = False
End Sub

 

[Villalobos]

Thank you wudixin96! Working well.