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.

 

[shah0101]

OK, progress...

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

Did I get the info correctly, you asked?

 

[Fuji]

OK,

Go to [View] - [Local Window]
Then you can see all the variables as soon as you hit F8.

When you get that error message, click on [Debug] and see Local Window and read the variable "fn"?

 

[shah0101]

OK,

Go to [View] - [Local Window]
Then you can see all the variables as soon as you hit F8.

When you get that error message, click on [Debug] and see Local Window and read the variable "fn"?

This one?

 

[shah0101]

OK,

Go to [View] - [Local Window]
Then you can see all the variables as soon as you hit F8.

When you get that error message, click on [Debug] and see Local Window and read the variable "fn"?

This:

 

[Fuji]

.Chome Remote Desktop.link

Do you have other file(s) other than Excel file?

Can you again try change the same line to

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * (LCase$(myFile.Name) Like "*.xls*") Then

 

[shah0101]

.Chome Remote Desktop.link

Do you have other file(s) other than Excel file?

Can you again try change the same line to

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * (LCase$(myFile.Name) Like "*.xls*") Then

1) No other files in this folder other than Excel
2) Replace the code
3) Below file name "Cash-Flow-Sample-001.xlsx" is also not in this folder.

 

[shah0101]

1) No other files in this folder other than Excel
2) Replace the code
3) Below file name "Cash-Flow-Sample-001.xlsx" is also not in this folder.


View attachment 119856

But I see the that this file came up on the desktop somehow, which was not there before running the code

 

[shah0101]

.Chome Remote Desktop.link

Do you have other file(s) other than Excel file?

Can you again try change the same line to

        If (myDir & myFile.Name <> ThisWorkbook.FullName) * (LCase$(myFile.Name) Like "*.xls*") Then

I may have missed to give one info that each of these Excel files (thousands) have multiple sheets and the range B53:O153 which I want to extract is in a sheet name "Data Entry" in each files.

 

[Fuji]

OK, that makes easier.

But you see the fn starting from "~", that means that file is currently open and it is not actually a file so we need to get rid of such one(s) too.
Back to my code in #51 and changed a bit.

Sub test()
    Dim myDir$, wsName$, r As Range, s$, x&, myFile As Object, fso As Object, temp, msg$
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = Dir(myDir, vbDirectory)
    Set r = [B53:O153]: wsName = "Data Entry"
    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) * _
            (LCase$(fso.getextensionname(myFile.Name)) Like "xls*") * _
            (Not myFile.Name Like "~*") Then
            s = "'" & myDir & "[" & myFile.Name & "]" & wsName & "'!" & r(1).Address(0, 0)
            temp = ExecuteExcel4Macro(s & "r1c1")
            If IsError(temp) Then
                msg = msg & vbLf & myFile.Name
            Else
                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
        End If
    Next
    If Len(msg) Then MsgBox "Foolowing file has not sheet named " & wsName & vbLf & msg
    Application.ScreenUpdating = True
End Sub

Should catch the correct file names...

 

[JEC]

Maybe a bit late to the party but this kind of procedures are very with the help of power query. You can do this all with just PQ UI.