VBA Script Pull Data from closed workbooks

oldvanman

New Member
Joined
Nov 9, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi Guys,

New to VBA so steep learning curve.

I read a number of threads particularly the Pull data from closed workbooks in same folder, as I have a similar challenge.This was between ( ceytl and johnnyL ) did some great work

So I have a 150 or so xlsx files in a dropbox folder called Invoices 2019-2021 and a file called Invoice register 1.xlsm for the macro and results.
Within the folder Invoices 2019-2021 I have a file typically starting at Inv 291.xlsx

I am am looking to get data from each xlsx file and list it down sequentially starting from A2 in my invoice register 1 file.
I would not want to open each of the xlsx files just to get the data.

thanks in advance
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
I do not have enough information to fit this code to your situation. If you study this you could make it

VBA Code:
Sub jec()
  Dim xx As String, fl As Object, ar As Variant
  xx = "C:\xx\xx\Documents\xx\xx\"                'your path
  Application.ScreenUpdating = False
  
  For Each fl In CreateObject("Scripting.filesystemobject").getfolder(xx).Files
    If Right(fl, 4) Like "xls*" Then    'relevant files
      With GetObject(fl).Sheets(1)
         ar = .Range("A6:A20")    'range to be copied
         ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
        .Parent.Close 0
      End With
    End If
  Next
End Sub
 
Upvote 0
Hi JEC
I do not have enough information to fit this code to your situation. If you study this you could make it

VBA Code:
Sub jec()
  Dim xx As String, fl As Object, ar As Variant
  xx = "C:\xx\xx\Documents\xx\xx\"                'your path
  Application.ScreenUpdating = False
 
  For Each fl In CreateObject("Scripting.filesystemobject").getfolder(xx).Files
    If Right(fl, 4) Like "xls*" Then    'relevant files
      With GetObject(fl).Sheets(1)
         ar = .Range("A6:A20")    'range to be copied
         ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
        .Parent.Close 0
      End With
    End If
  Next
End Sub


Thanks for the quick reply

I have filled in the path
and relevant *.xlsx?

I have the data in the invoice files is located in Cells B20,E4,E5,E19,E31,E33 and E34 these then would then be copied to A2:G2 and fill down for each invoice.

Thanks
 
Upvote 0
Then something like this

VBA Code:
Sub jec()
  Dim xx As String, fl As Object, ar As Variant
  xx = "C:\xx\xx\Documents\xx\xx\"                'your path
  Application.ScreenUpdating = False
 
  For Each fl In CreateObject("Scripting.filesystemobject").getfolder(xx).Files
    If Right(fl, 4) Like "xls*" Then    'relevant files
      With GetObject(fl).Sheets(1)
         ar = Array(.[B20].Value, .[E4].Value, .[E5].Value, .[E19].Value, .[E31].Value, .[E33].Value, .[E34].Value)
         ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(ar) + 1) = ar
        .Parent.Close 0
      End With
    End If
  Next
End Sub
 
Upvote 0
Then something like this

VBA Code:
Sub jec()
  Dim xx As String, fl As Object, ar As Variant
  xx = "C:\xx\xx\Documents\xx\xx\"                'your path
  Application.ScreenUpdating = False
 
  For Each fl In CreateObject("Scripting.filesystemobject").getfolder(xx).Files
    If Right(fl, 4) Like "xls*" Then    'relevant files
      With GetObject(fl).Sheets(1)
         ar = Array(.[B20].Value, .[E4].Value, .[E5].Value, .[E19].Value, .[E31].Value, .[E33].Value, .[E34].Value)
         ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(ar) + 1) = ar
        .Parent.Close 0
      End With
    End If
  Next
End Sub
VBA Code:
Sub jec()
  Dim xx As String, fl As Object, ar As Variant
  xx = "C:\Users\thomas\Dropbox\Invoices2019-2021\"                'your path
  Application.ScreenUpdating = False
  
  For Each fl In CreateObject("Scripting.filesystemobject").getfolder(xx).Files
    If Right(fl, 4) Like "xlsx*" Then    'relevant files
      With GetObject(fl).Sheets(1)
         ar = Array(.[B10].Value, .[E4].Value, .[E5].Value, .[E19].Value, .[E31].Value, .[E33].Value, .[E34].Value)
         ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
        .Parent.Close 0
      End With
    End If
  Next
End Sub

The code seems to stop and show nothing in the target file workbook.

Thanks for your help
 
Upvote 0
Step with F8 through the code and see where its goes wrong. Does it error?

You also didn't use my last code.
The line below is different(this is the right one)

VBA Code:
 ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(ar) + 1) = ar

One more thing, if you only search for xlsx files, you don't need the * at the end
 
Last edited:
Upvote 0
Step with F8 through the code and see where its goes wrong. Does it error?

You also didn't use my last code.
The line below is different(this is the right one)

VBA Code:
 ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, UBound(ar) + 1) = ar

One more thing, if you only search for xlsx files, you don't need the * at the end
Hi JEC,
I updated the code as suggested.
When I step F8 it goes as far as For Each f1.... and then jumps to End Sub
My Excel sheet seems to go blank.

Thanks
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,291
Members
448,564
Latest member
ED38

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