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.

 

[Fuji]

OK, the file names are something that Dir function can not catch.
See if the code runs properly.
Replace "test" sub procedure with the following while the other function remains intact.

Sub test()
    Dim myDir$, wsName$, r As Range, s$, x As Long, myFile As Object, fso As Object
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = Dir(myDir, vbDirectory)
    Set r = [B53:O153]
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.GetFolder(myDir).Files.Count = 0 Then MsgBox "No files": Exit Sub
    For Each myFile In fso.GetFolder(myDir).Files
        If (myDir & myFile.Name <> ThisWorkbook.FullName) * _
            (fso.getextensionname(myFile.Name) Like "xls*") * _
            (Not myFile.Name Like "~*") Then
            wsName = GetSheetName(myDir & myFile.Name)
            s = "'" & myDir & "[" & myFile.Name & "]" & 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 & myFile.Name & ";" & 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
    Next
    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

@Fuji I am not sure that will fix the issue since the issue is this line:
myDir = Dir(strDir, vbDirectory)
At that point you have trashed your file path and replaced it with "."
Remove that line and either add another variable or change the line below to what I have:

If Dir(myDir, vbDirectory) = "" Then MsgBox "Wrong path": Exit Sub

 

[shah0101]

OK, the file names are something that Dir function can not catch.
See if the code runs properly.
Replace "test" sub procedure with the following while the other function remains intact.

Sub test()
    Dim myDir$, wsName$, r As Range, s$, x As Long, myFile As Object, fso As Object
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = Dir(myDir, vbDirectory)
    Set r = [B53:O153]
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.GetFolder(myDir).Files.Count = 0 Then MsgBox "No files": Exit Sub
    For Each myFile In fso.GetFolder(myDir).Files
        If (myDir & myFile.Name <> ThisWorkbook.FullName) * _
            (fso.getextensionname(myFile.Name) Like "xls*") * _
            (Not myFile.Name Like "~*") Then
            wsName = GetSheetName(myDir & myFile.Name)
            s = "'" & myDir & "[" & myFile.Name & "]" & 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 & myFile.Name & ";" & 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
    Next
    Application.ScreenUpdating = True
End Sub

Recorded results, not sure but looks like first "IF" has some issues, Please guide / advise

 

[shah0101]

@Fuji I am not sure that will fix the issue since the issue is this line:
myDir = Dir(strDir, vbDirectory)
At that point you have trashed your file path and replaced it with "."
Remove that line and either add another variable or change the line below to what I have:

If Dir(myDir, vbDirectory) = "" Then MsgBox "Wrong path": Exit Sub

Thanks Alex for getting involved.

Can you please copy and paste the whole code with your suggested changes please.

 

[Fuji]

Hummm, try change

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * _
            (fso.getextensionname(myFile.Name) Like "xls*") * _
            (Not myFile.Name Like "~*") Then

to

        If Not myFile.Name Like "~*" Then

Alex;
No such line in my code.

   myDir = Dir(strDir, vbDirectory)

 

[Alex Blakenburg]

I'd rather not do that since its Fuji's code:
Using his post 51. Remove what is struck out and add the blue line:
(this is instead of the changes Fuji recommended above in post 55)

Sub Fuji_51()
    Dim myDir$, wsName$, r As Range, s$, x As Long, myFile As Object, fso As Object
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = Dir(myDir, vbDirectory)
    Set r = [B53:O153]
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    If Dir(myDir, vbDirectory)= "" Then MsgBox "Wrong path": Exit Sub
    Application.ScreenUpdating = False

@Fuji - I added a variable for my testing that was meant to say myDir not strDir.

 

[shah0101]

Hummm, try change

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * _
            (fso.getextensionname(myFile.Name) Like "xls*") * _
            (Not myFile.Name Like "~*") Then

to

        If Not myFile.Name Like "~*" Then

Alex;
No such line in my code.

   myDir = Dir(strDir, vbDirectory)

Stuck in function:

 

[shah0101]

I'd rather not do that since its Fuji's code:
Using his post 51. Remove what is struck out and add the blue line:
(this is instead of the changes Fuji recommended above in post 55)

Sub Fuji_51()
    Dim myDir$, wsName$, r As Range, s$, x As Long, myFile As Object, fso As Object
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = Dir(myDir, vbDirectory)
    Set r = [B53:O153]
    If myDir = "" Then MsgBox "Wrong path": Exit Sub
    If Dir(myDir, vbDirectory)= "" Then MsgBox "Wrong path": Exit Sub
    Application.ScreenUpdating = False

@Fuji - I added a variable for my testing that was meant to say myDir not strDir.

Thanks Alex.

Fuji, can you please look into it and advise please.

 

[shah0101]

Hummm, try change

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * _
            (fso.getextensionname(myFile.Name) Like "xls*") * _
            (Not myFile.Name Like "~*") Then

to

        If Not myFile.Name Like "~*" Then

Alex;
No such line in my code.

   myDir = Dir(strDir, vbDirectory)

 

[Fuji]

OK, progress...

When the code goes into debug mode, can you read "fn" by hover over the cursor(not click) over to that variable?