Gathering Data From Multiple Files in Same Folder in Particular Range

[shah0101]

Hi Expert,

Is there a way to extract data from hundreds of files in single folder from particular range? I googled and found various options but none of them seems to be working with me.

Basically all files in one folder and range is B53:O153.

I would prefer the power query but query is bringing up only top rows and I can not figure out where to put in range, I am using Excel 2021, can anyone help to guide me please..

Also tried below code but it goes on and on and then I have to forcibly close Excel to stop.

Sub CopyValuesFromFiles()
Dim sourceFolder As String
Dim sourceFiles As Object
Dim sourceFile As Object
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim destinationRow As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Set the path to the source folder modify accordingly
sourceFolder = "Z:\DOCUMENTS\INVOICES- 24-25"

' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Customers")

' Initialize the destination row
destinationRow = 2

' Create a FileSystemObject to work with files in the folder
Set sourceFiles = CreateObject("Scripting.FileSystemObject").GetFolder(sourceFolder).Files

' Loop through each file in the folder
For Each sourceFile In sourceFiles
' Check if the file is an Excel file
If sourceFile.Name Like "*.xlsm*" Then
' Open the source workbook
Set wbSource = Workbooks.Open(sourceFile.Path)

' Copy the values from B53 to O153
wbSource.Worksheets(1).Range("B53:O153").Copy

' Paste the values to the destination worksheet
wsDestination.Range("A" & destinationRow).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Update the destination row for the next set of values
destinationRow = destinationRow + 1

' Close the source workbook without saving changes
wbSource.Close SaveChanges:=False
End If
Next sourceFile

' Clear the clipboard
Application.CutCopyMode = False

' Display a message when the copying is complete
MsgBox "Copying customer information from files complete."

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub




Thanks in advance.

 

[NdNoviceHlp]

The code in #2 and #26 both work! Dave

 

[kvsrinivasamurthy]

Try this code

Sub CopyValuesFromFiles()
Dim sourceFolder As String
Dim sourceFiles As Object
Dim sourceFile As Object
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim destinationRow As Long
Dim T&, Ta&
Dim A(1 To 100)   'Assuming there are a maximum of 100 required files.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Set the path to the source folder modify accordingly
sourceFolder = "Z:\DOCUMENTS\INVOICES- 24-25"

' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Sheet1")

' Initialize the destination row
destinationRow = 2

' Create a FileSystemObject to work with files in the folder
Set sourceFiles = CreateObject("Scripting.FileSystemObject").GetFolder(sourceFolder).Files

'With CreateObject("scripting.dictionary")

' Loop through each file in the folder
For Each sourceFile In sourceFiles
' Check if the file is an Excel file
If sourceFile.Name Like "*.xlsm*" Then
' Open the source workbook
Set wbSource = Workbooks.Open(sourceFile.Path)
T = T + 1
' Copy the values from B53 to O153
A(T) = wbSource.Worksheets(1).Range("B53:O153")

' Close the source workbook without saving changes
wbSource.Close SaveChanges:=False
End If
Next sourceFile

For Ta = 1 To T
wsDestination.Range("A" & destinationRow).Resize(101, 14) = A(Ta)
destinationRow = destinationRow + 101
Next Ta

' Display a message when the copying is complete
MsgBox "Copying customer information from files complete."

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[shah0101]

Try this code

Sub CopyValuesFromFiles()
Dim sourceFolder As String
Dim sourceFiles As Object
Dim sourceFile As Object
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim destinationRow As Long
Dim T&, Ta&
Dim A(1 To 100)   'Assuming there are a maximum of 100 required files.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Set the path to the source folder modify accordingly
sourceFolder = "Z:\DOCUMENTS\INVOICES- 24-25"

' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Sheet1")

' Initialize the destination row
destinationRow = 2

' Create a FileSystemObject to work with files in the folder
Set sourceFiles = CreateObject("Scripting.FileSystemObject").GetFolder(sourceFolder).Files

'With CreateObject("scripting.dictionary")

' Loop through each file in the folder
For Each sourceFile In sourceFiles
' Check if the file is an Excel file
If sourceFile.Name Like "*.xlsm*" Then
' Open the source workbook
Set wbSource = Workbooks.Open(sourceFile.Path)
T = T + 1
' Copy the values from B53 to O153
A(T) = wbSource.Worksheets(1).Range("B53:O153")

' Close the source workbook without saving changes
wbSource.Close SaveChanges:=False
End If
Next sourceFile

For Ta = 1 To T
wsDestination.Range("A" & destinationRow).Resize(101, 14) = A(Ta)
destinationRow = destinationRow + 101
Next Ta

' Display a message when the copying is complete
MsgBox "Copying customer information from files complete."

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

@kvsrinivasamurthy

Tried this as well and the error is as below picture.

I think I will go crazy by copying and pasting each and every file...... By the way the number of files now reached to 5800+ and still counting.

Can you please help!!

Task is still the same:
To bring up range: B53:O153 + Cell "B1" + Cell "B15" from hundreds (now thousands) of files lying in the same folder:
Z:\DOCUMENTS\INVOICES- 24-25

B1 and B15 should repeat on any left cells against each entry of same range B53:O135 of same file.

Please help!

 

[Fuji]

Differnt method and should be much faster.

Sub test()
    Dim myDir$, fn$, wsName$, r As Range, s$, x As Long
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"  '<--- Need path separator at the end
    myDir = Dir(myDir, vbDirectory)
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    Application.ScreenUpdating = False
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            wsName = GetSheetName(myDir & fn)
            s = "'" & myDir & "[" & fn & "]" & wsName & "'!" & r(1).Address(0, 0)
            With ThisWorkbook.Sheets("Customers")
                With Intersect(.UsedRange, .Columns("a").Resize(, r.Columns.Count))
                    x = .Parent.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))")
                End With
                With .Cells(x + 1, 1)
                    .Value = myDir & fn & ";" & wsName
                    With .Cells(2, 1).Resize(r.Rows.Count, r.Columns.Count)
                        .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                        .Value = .Value
                    End With
                End With
            End With
        End If
        fn = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Function GetSheetName(fn As String)
    GetSheetName = Replace(CreateObject("DAO.DBEngine.120").OpenDatabase(fn, _
        False, False, "Excel 5.0;hdr=No").TableDefs(0).Name, "$", "")
End Function

 

[shah0101]

Differnt method and should be much faster.

Sub test()
    Dim myDir$, fn$, wsName$, r As Range, s$, x As Long
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"  '<--- Need path separator at the end
    myDir = Dir(myDir, vbDirectory)
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    Application.ScreenUpdating = False
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            wsName = GetSheetName(myDir & fn)
            s = "'" & myDir & "[" & fn & "]" & wsName & "'!" & r(1).Address(0, 0)
            With ThisWorkbook.Sheets("Customers")
                With Intersect(.UsedRange, .Columns("a").Resize(, r.Columns.Count))
                    x = .Parent.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))")
                End With
                With .Cells(x + 1, 1)
                    .Value = myDir & fn & ";" & wsName
                    With .Cells(2, 1).Resize(r.Rows.Count, r.Columns.Count)
                        .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                        .Value = .Value
                    End With
                End With
            End With
        End If
        fn = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Function GetSheetName(fn As String)
    GetSheetName = Replace(CreateObject("DAO.DBEngine.120").OpenDatabase(fn, _
        False, False, "Excel 5.0;hdr=No").TableDefs(0).Name, "$", "")
End Function

Thank you sooo very much for getting involved @Fuji . Thanks Thanks Thanks.

I tried to run but nothing seems to be happening..... I am not that tech savy, can you please guide what am I doing wrong please?

 

[shah0101]

Differnt method and should be much faster.

Sub test()
    Dim myDir$, fn$, wsName$, r As Range, s$, x As Long
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"  '<--- Need path separator at the end
    myDir = Dir(myDir, vbDirectory)
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    Application.ScreenUpdating = False
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            wsName = GetSheetName(myDir & fn)
            s = "'" & myDir & "[" & fn & "]" & wsName & "'!" & r(1).Address(0, 0)
            With ThisWorkbook.Sheets("Customers")
                With Intersect(.UsedRange, .Columns("a").Resize(, r.Columns.Count))
                    x = .Parent.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))")
                End With
                With .Cells(x + 1, 1)
                    .Value = myDir & fn & ";" & wsName
                    With .Cells(2, 1).Resize(r.Rows.Count, r.Columns.Count)
                        .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                        .Value = .Value
                    End With
                End With
            End With
        End If
        fn = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Function GetSheetName(fn As String)
    GetSheetName = Replace(CreateObject("DAO.DBEngine.120").OpenDatabase(fn, _
        False, False, "Excel 5.0;hdr=No").TableDefs(0).Name, "$", "")
End Function

I have uploaded the screen video:

You can now see how desperate I am to get this help!

 

[Fuji]

Most probably, no excel files in the folder.

What you can do is Step Debugging.

While you are in vbe,

1) Click somewhere on "test" sub procedue.
2) Hit F8.
3) As you hit F8, the code executes one line.
4) When you reach the line of

    Do While fn <> ""

See if the code goes to next line.

 

[shah0101]

Most probably, no excel files in the folder.

What you can do is Step Debugging.

While you are in vbe,

1) Click somewhere on "test" sub procedue.
2) Hit F8.
3) As you hit F8, the code executes one line.
4) When you reach the line of

    Do While fn <> ""

See if the code goes to next line.

Looks like its stuck in the loop without getting in data, recorded as below:

Please guide / advise....

 

[Fuji]

That means no excel files in the folder.
Can you just add one line in bold and run?

    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    If fn = "" Then MsgBox "No Excel file in the folder": Exit Sub   '<--- this line
    Application.ScreenUpdating = False

 

[shah0101]

That means no excel files in the folder.
Can you just add one line in bold and run?

    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    If fn = "" Then MsgBox "No Excel file in the folder": Exit Sub   '<--- this line
    Application.ScreenUpdating = False

Yes, it does says no excel file in the folder. Is the path incorrect? or the file extension issue? these are XLSM files, does that make a difference?