patternMinor

Retrieving data from files in the folder

Submitted by: @import:stackexchange-codereview·Mar 10, 2026·

Viewed 0 times

thefilesfolderretrievingfromdata

Problem

I am to use VBA code to simply retrieve certain data from all Excel files in certain folder and paste it in working spreadsheet. I am not sure that this is the most efficient (which matters as I would like to learn how to write the most possible efficient codes).

I am using simple copy/paste actions but maybe there are more sophisticated methods (which could help me in the future if for example I would need to get data with certain words in contiguous column in the worksheets, or to order it by date of file creation), or maybe there is better way how to get to the files, or maybe a better to do this and how using forms and tables.

Option Explicit
Sub copydata()
Dim script As Object
Dim catalogue As Object
Dim textfile As Object
Dim loadedfile As Workbook
Dim actualfile As Workbook
Dim path As String
Dim column_index As Integer
path = InputBox("Please input path")
Application.ScreenUpdating = False
Set actualfile = ActiveWorkbook
Set script = CreateObject("Scripting.FileSystemObject")
Set catalogue = script.GetFolder(path)
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
   For Each textfile In catalogue.Files

      Workbooks.Open textfile
      Set loadedfile = ActiveWorkbook
      loadedfile.Worksheets(1).Range("D1:D15").Copy
      column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count
      actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
      loadedfile.Close Savechanges:=False

    Next textfile

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Solution

There is a few things I would fix:

find a better way to grab the path - don't let the user type the path manually as he can easily make a typo and you procedure would fail as you're not currently really checking if the path provided is correct/(exist). Remember not to ever trust user with their input in your programs.

For example, consider this code which shows a box to select the folder (note you can even pass the initial path to it by providing a parameter)

Additionally: If you wanted to point to "My Computer" by default see this workaround on my blog.

Sub Main()

    Dim path As String
    path = GetFolder("") & "\"

    Debug.Print path
End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Early vs. late binding

I see you are late binding your objects. There are tons of discussions what is better and why so I am not going to judge here all I can see is that all it takes to get intelli-sense and a better performance is adding references to Microsoft Scripting Runtime via the Tools -> References in VBE (Visual Basic Editor).

Now, if you combine the tips from above you could get a little bit revised but better version of you code

Sub Copydata()

    Dim path As String
    path = GetFolder("") & "\"

    Dim script As FileSystemObject
    Set script = New FileSystemObject

    Dim catalogue As Folder
    Set catalogue = script.GetFolder(path)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Dim textfile As File
    Dim column_index As Integer
    Dim loadedfile As Workbook

    Dim actualfile As Workbook
    Set actualfile = ActiveWorkbook

    For Each textfile In catalogue.Files

        Workbooks.Open textfile
        Set loadedfile = ActiveWorkbook
        loadedfile.Worksheets(1).Range("D1:D15").Copy
        column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count
        actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
        loadedfile.Close Savechanges:=False

    Next textfile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Great, so now you probably want to eliminate opening each workbook just to copy data. There are various ways to pull data from opened and closed workbooks (without actually opening them) and I am going to use the ADODB way in your example.

Note, you need to add references to Microsoft ActiveX Data Objects 6.1 Library for this to work but the efficiency should increase a lot because you do not open the files just to get 15 rows out of them.

Let's start with a very simple example:

Assuming there is a folder temp on you C:\ drive and there is a file1.xlsm in it

Sub Pull_Data_from_Excel_with_ADODB()

    Dim cnStr As String
    Dim rs As ADODB.Recordset
    Dim query As String

    Dim fileName As String
    fileName = "C:\temp\file1.xlsm"

    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & fileName & ";" & _
               "Extended Properties=Excel 12.0"

    query = "SELECT * FROM [Sheet1$D1:D15]"

    Set rs = New ADODB.Recordset
    rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified

    Cells.Clear
    Range("A2").CopyFromRecordset rs
    Dim cell As Range, i As Long
    'headers
    With Range("A1").CurrentRegion
        For i = 0 To rs.Fields.Count - 1
            .Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        .EntireColumn.AutoFit
    End With
End Sub

See, this does not open the file and allows you to pull the D1:D15 from it.

Now if you slightly modify the code to suit your example you get a fully working and efficient code

```
Option Explicit

Sub Copydata()

Dim path As String
' retrieve the path to the folder with the files to pull data from
path = GetFolder("") & "\"

Dim script As FileSystemObject
Set script = New FileSystemObject

Dim catalogue As Folder
Set catalogue = script.GetFolder(path)

Application.ScreenUpdating = False
Ap

Code Snippets

Sub Main()

    Dim path As String
    path = GetFolder("") & "\"

    Debug.Print path
End Sub


' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Copydata()

    Dim path As String
    path = GetFolder("") & "\"

    Dim script As FileSystemObject
    Set script = New FileSystemObject

    Dim catalogue As Folder
    Set catalogue = script.GetFolder(path)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False


    Dim textfile As File
    Dim column_index As Integer
    Dim loadedfile As Workbook

    Dim actualfile As Workbook
    Set actualfile = ActiveWorkbook

    For Each textfile In catalogue.Files

        Workbooks.Open textfile
        Set loadedfile = ActiveWorkbook
        loadedfile.Worksheets(1).Range("D1:D15").Copy
        column_index = actualfile.Worksheets(1).Range("A5").CurrentRegion.Columns.Count
        actualfile.Worksheets(1).Range("A5").Offset(0, column_index).PasteSpecial
        loadedfile.Close Savechanges:=False

    Next textfile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Sub Pull_Data_from_Excel_with_ADODB()

    Dim cnStr As String
    Dim rs As ADODB.Recordset
    Dim query As String

    Dim fileName As String
    fileName = "C:\temp\file1.xlsm"

    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & fileName & ";" & _
               "Extended Properties=Excel 12.0"

    query = "SELECT * FROM [Sheet1$D1:D15]"

    Set rs = New ADODB.Recordset
    rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified

    Cells.Clear
    Range("A2").CopyFromRecordset rs
    Dim cell As Range, i As Long
    'headers
    With Range("A1").CurrentRegion
        For i = 0 To rs.Fields.Count - 1
            .Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        .EntireColumn.AutoFit
    End With
End Sub

Option Explicit

Sub Copydata()

    Dim path As String
    ' retrieve the path to the folder with the files to pull data from
    path = GetFolder("") & "\"

    Dim script As FileSystemObject
    Set script = New FileSystemObject

    Dim catalogue As Folder
    Set catalogue = script.GetFolder(path)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Dim cnStr As String
    Dim rs As ADODB.Recordset

    Dim query As String
    ' SQL query to pull D1:D15 from Sheet1 in each file
    query = "SELECT * FROM [Sheet1$D1:D15]"

    Dim wbFile As Variant

    ' iterate through the files in the folder user selected
    For Each wbFile In catalogue.Files

        ' upate the connection string with path to each file
        cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & wbFile & ";" & _
               "Extended Properties=Excel 12.0"

        ' populate a recordset with D1:D15 from each file
        Set rs = New ADODB.Recordset
        rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified

        ' Copy data from recordset to range in one go
        Range("A5").Offset(0, Range("A5").CurrentRegion.Columns.Count).CopyFromRecordset rs

        ' close the recordset and free memory
        rs.Close
        Set rs = Nothing
    Next wbFile

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True

End Sub

' strPath is the initial path
Private Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Context

StackExchange Code Review Q#51662, answer score: 6

Revisions (0)

No revisions yet.