Pull data from closed workbooks in same folder

C

ceytl

Board Regular
Joined
Jun 6, 2009
Messages
114
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I have been looking for VBA script that can go into all the closed .xlsx files in a folder called S1 and grab the data from cells B5, H7, F19, F20, F21, and then put these values in A2, B2, C2, D2, E2

There is about 100 files, and the path is: c:\Users\US\Desktop\S1

is this something that can be done?

Thanks,
 
Sort by date Sort by votes
Eric W said:
In my version, no. You have to know the complete address of the cell.
Click to expand...
It can be done, accurately, if there is only one sheet in the closed workbook.

VBA Code: 
Sub LoopThroughFilesV4()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   Workbook remains closed the entire time.
'
    Dim SourceDirectory As String, SourcefileName As String, DestinationSheetName As String, SourceSheetName As String
    Dim DestinationRow  As Long, MyCell As Range
    Dim conexion        As Object
    Dim objCat          As Object
'
    Application.ScreenUpdating = False
 '
    Set conexion = CreateObject("adodb.connection")
    Set objCat = CreateObject("ADOX.Catalog")
'
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
'
    SourceDirectory = "c:\Users\US\Desktop\S1\"
'
    DestinationSheetName = "Sheet1"                                                     ' <--- Set this to the Destination Sheet Name
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        conexion.Close
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Cells(DestinationRow, "A")
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B5"
        MyCell.Offset(, 1).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!H7"
        MyCell.Offset(, 2).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F19"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F20"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F21"
''        MyCell.Resize(1, 5).Value = MyCell.Resize(1, 5).Value
        
        SourcefileName = Dir
    Loop
'
    Set objCat = Nothing
    Set conexion = Nothing
'
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
ceytl said:
Thank you!

Is there a way to change the DestinationSheetName to the 1st or active worksheet in the workbook, since some of the worksheets don't have the same name, and all my .xlsx have only one worksheet per file.

Lastly, is there a way to change the destination directory to something that would allow me to share the macro without changing the script.

The spreadsheet could be in folder S1 on the desktop, and all the files could be in a folder name S2 that is located in S1.

Thanks!
Click to expand...
@ceytl, if you have only one worksheet in each workbook, see post #22, I have included code to handle that without a need to open the workbook.

As far as changing the directory used for all of the workbooks that you want to get data from, you could use code to ask the user which directory the files are in. ;)
 
Upvote 0
johnnyL said:
It can be done, accurately, if there is only one sheet in the closed workbook.

VBA Code: 
Sub LoopThroughFilesV4()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   Workbook remains closed the entire time.
'
    Dim SourceDirectory As String, SourcefileName As String, DestinationSheetName As String, SourceSheetName As String
    Dim DestinationRow  As Long, MyCell As Range
    Dim conexion        As Object
    Dim objCat          As Object
'
    Application.ScreenUpdating = False
 '
    Set conexion = CreateObject("adodb.connection")
    Set objCat = CreateObject("ADOX.Catalog")
'
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
'
    SourceDirectory = "c:\Users\US\Desktop\S1\"
'
    DestinationSheetName = "Sheet1"                                                     ' <--- Set this to the Destination Sheet Name
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        conexion.Close
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Cells(DestinationRow, "A")
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B5"
        MyCell.Offset(, 1).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!H7"
        MyCell.Offset(, 2).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F19"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F20"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F21"
''        MyCell.Resize(1, 5).Value = MyCell.Resize(1, 5).Value
       
        SourcefileName = Dir
    Loop
'
    Set objCat = Nothing
    Set conexion = Nothing
'
    Application.ScreenUpdating = True
End Sub
Click to expand...


Thank you @johnnyL!

It works super fast!

The only downside is that the worksheet name cannot start with a number, or have a space in it.
 
Upvote 0
ceytl said:
The only downside is that the worksheet name cannot start with a number, or have a space in it.
Click to expand...
How about:

VBA Code: 
Sub LoopThroughFilesV5()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   Workbook remains closed the entire time.
'
    Dim SourceDirectory As String, SourcefileName As String, DestinationSheetName As String, SourceSheetName As String
    Dim DestinationRow  As Long, MyCell As Range
    Dim conexion        As Object
    Dim objCat          As Object
'
    Application.ScreenUpdating = False
 '
    Set conexion = CreateObject("adodb.connection")
    Set objCat = CreateObject("ADOX.Catalog")
'
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
'
    SourceDirectory = "c:\Users\US\Desktop\S1\"
'
    DestinationSheetName = "Sheet1"                                                     ' <--- Set this to the Destination Sheet Name
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Cells(DestinationRow, "A")
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B5"
        MyCell.Offset(, 1).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!H7"
        MyCell.Offset(, 2).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F19"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F20"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F21"
''        MyCell.Resize(1, 5).Value = MyCell.Resize(1, 5).Value
        
        SourcefileName = Dir
    Loop
'
    Set objCat = Nothing
    Set conexion = Nothing
'
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
johnnyL said:
How about:

VBA Code: 
Sub LoopThroughFilesV5()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   Workbook remains closed the entire time.
'
    Dim SourceDirectory As String, SourcefileName As String, DestinationSheetName As String, SourceSheetName As String
    Dim DestinationRow  As Long, MyCell As Range
    Dim conexion        As Object
    Dim objCat          As Object
'
    Application.ScreenUpdating = False
 '
    Set conexion = CreateObject("adodb.connection")
    Set objCat = CreateObject("ADOX.Catalog")
'
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
'
    SourceDirectory = "c:\Users\US\Desktop\S1\"
'
    DestinationSheetName = "Sheet1"                                                     ' <--- Set this to the Destination Sheet Name
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Cells(DestinationRow, "A")
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B5"
        MyCell.Offset(, 1).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!H7"
        MyCell.Offset(, 2).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F19"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F20"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F21"
''        MyCell.Resize(1, 5).Value = MyCell.Resize(1, 5).Value
      
        SourcefileName = Dir
    Loop
'
    Set objCat = Nothing
    Set conexion = Nothing
'
    Application.ScreenUpdating = True
End Sub
Click to expand...

johnnyL said:
How about:

VBA Code: 
Sub LoopThroughFilesV5()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   Workbook remains closed the entire time.
'
    Dim SourceDirectory As String, SourcefileName As String, DestinationSheetName As String, SourceSheetName As String
    Dim DestinationRow  As Long, MyCell As Range
    Dim conexion        As Object
    Dim objCat          As Object
'
    Application.ScreenUpdating = False
 '
    Set conexion = CreateObject("adodb.connection")
    Set objCat = CreateObject("ADOX.Catalog")
'
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
'
    SourceDirectory = "c:\Users\US\Desktop\S1\"
'
    DestinationSheetName = "Sheet1"                                                     ' <--- Set this to the Destination Sheet Name
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Cells(DestinationRow, "A")
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B5"
        MyCell.Offset(, 1).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!H7"
        MyCell.Offset(, 2).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F19"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F20"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!F21"
''        MyCell.Resize(1, 5).Value = MyCell.Resize(1, 5).Value
       
        SourcefileName = Dir
    Loop
'
    Set objCat = Nothing
    Set conexion = Nothing
'
    Application.ScreenUpdating = True
End Sub
Click to expand...

Thank you again @johnnyL! It went through all the files except ones with a ' , but I just deleted them from the file name and worksheet, and it works great!.

My last question is there a way to change the SourceDirectory = "c:\Users\US\Desktop\S1\ to an Activeworkbook.Path with a sub folder?

I would put the .xlsm file in S1, and move all the .xlsx files to a sub folder in S1 called Temp:

Would something like this work? Activeworkbook.Path & "\Temp\
 
Upvote 0
Yes, that would work. SourceDirectory = ActiveWorkbook.Path & "\Temp\"
 
Upvote 0
ceytl said:
Thank you again @johnnyL! It went through all the files except ones with a ' , but I just deleted them from the file name and worksheet, and it works great!.
Click to expand...
Ok, just an update. I got bored today so I decided to address that issue of an apostrophe in the file name.

I made a few programming changes as well as, used some different names and ranges during the testing so just adjust those according to you situation:

VBA Code: 
Sub PullDatafomClosedWBV2()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim DestinationSheetName As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow  As Long
    Dim conexion        As Object, objCat As Object
'
    DestinationSheetName = "Unit_Data"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = ActiveWorkbook.Path & "\Orders\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        With ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow & ":H" & DestinationRow)
            .Formula = Array( _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G26", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G27", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G28", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G34", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G35", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G36", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G39")
            .Value = .Value                                                                     ' Remove formulas from range, leave just the resulting values
        End With
'
        SourcefileName = Dir
    Loop
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

Let us know if that handles your files with the ' in the name in addition to the other file names.
 
Upvote 0
johnnyL said:
Ok, just an update. I got bored today so I decided to address that issue of an apostrophe in the file name.

I made a few programming changes as well as, used some different names and ranges during the testing so just adjust those according to you situation:

VBA Code: 
Sub PullDatafomClosedWBV2()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim DestinationSheetName As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow  As Long
    Dim conexion        As Object, objCat As Object
'
    DestinationSheetName = "Unit_Data"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = ActiveWorkbook.Path & "\Orders\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        With ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow & ":H" & DestinationRow)
            .Formula = Array( _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G26", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G27", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G28", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G34", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G35", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G36", _
                "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G39")
            .Value = .Value                                                                     ' Remove formulas from range, leave just the resulting values
        End With
'
        SourcefileName = Dir
    Loop
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

Let us know if that handles your files with the ' in the name in addition to the other file names.
Click to expand...


The code works great, and it's so fast! Thank you so much!!!

One last thing, sometimes I use up to 160 lines, and if I use more than 25 lines with your new script I get too many line continuations.

Is there anything I can change to make it work if I need to do more than 25 lines?
 
Upvote 0
ceytl said:
The code works great, and it's so fast! Thank you so much!!!

One last thing, sometimes I use up to 160 lines, and if I use more than 25 lines with your new script I get too many line continuations.

Is there anything I can change to make it work if I need to do more than 25 lines?
Click to expand...
Try this version:

VBA Code: 
Sub PullDatafomClosedWBV2_5()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    DestinationSheetName = "Unit_Data"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = ActiveWorkbook.Path & "\Orders\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25:G28" & ")"
        MyCell.Offset(, 4).Resize(1, 3).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G34:G36" & ")"
        MyCell.Offset(, 7).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G39"
'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub
 
Upvote 0
johnnyL said:
Try this version:

VBA Code: 
Sub PullDatafomClosedWBV2_5()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    DestinationSheetName = "Unit_Data"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = ActiveWorkbook.Path & "\Orders\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25:G28" & ")"
        MyCell.Offset(, 4).Resize(1, 3).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G34:G36" & ")"
        MyCell.Offset(, 7).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G39"
'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub
Click to expand...


Thank you, you're amazing!!!

The new script runs so much faster than the old one!
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
VBA to pull data from closed workbooks
Replies
3
Views
525
Logit
Logit
J
  • Question
Power Query - Data Refresh Error in Macro
Replies
3
Views
177
bobsan42
bobsan42
J
  • Solved
Get data from dynamic location and filename on closed workbook using VBA
2 3 4
Replies
33
Views
1K
eiloken
E
G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
401
glynn1969
G
R
  • Solved
Color and Fonts changing when worksheet is pulled into active workbook
Replies
5
Views
125
Joe4
Joe4

Forum statistics

Threads
1,215,433
Messages
6,124,861
Members
449,195
Latest member
MoonDancer

Share this page

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