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, 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...

Tried the code, waited for about 15-20 minutes but nothing came up. Seems like moving in endless loop.

 

[Fuji]

OK, it is obviously a matter of file names.
This will list all the file names in Immediate Window ([View] - [Immediate Window]), so can you list some of them?

Sub ListFiles()
    Dim myDir$, wsName$, r As Range, myList(), n&, fso As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = ThisWorkbook.Path & "\"
    If Not fso.folderexists(myDir) Then MsgBox "No such folder": Exit Sub
    For Each myFile In fso.GetFolder(myDir).Files
        n = n + 1
        ReDim Preserve myList(1 To n)
        myList(n) = myDir & myFile.Name
    Next
    If n = 0 Then MsgBox "No file found": Exit Sub
    Debug.Print Join(myList, vbLf)
End Sub

 

[shah0101]

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.

Thanks JEC for getting involved. Yes, I tried that many times to best of my abilities (which are not much in tech world ) and I am unable to understand or do anything beyond "Transform Data"

Can you please guide / advise.

Thanks.

 

[shah0101]

OK, it is obviously a matter of file names.
This will list all the file names in Immediate Window ([View] - [Immediate Window]), so can you list some of them?

Sub ListFiles()
    Dim myDir$, wsName$, r As Range, myList(), n&, fso As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    myDir = "Z:\DOCUMENTS\INVOICES- 24-25\"
    myDir = ThisWorkbook.Path & "\"
    If Not fso.folderexists(myDir) Then MsgBox "No such folder": Exit Sub
    For Each myFile In fso.GetFolder(myDir).Files
        n = n + 1
        ReDim Preserve myList(1 To n)
        myList(n) = myDir & myFile.Name
    Next
    If n = 0 Then MsgBox "No file found": Exit Sub
    Debug.Print Join(myList, vbLf)
End Sub

Should I add this to exisiting code please? top? bottom?

 

[Fuji]

No, the code is stand alone.

 

[shah0101]

No, the code is stand alone.

This brought many files, but these are totally different files which doesn't belong to this particular folder which we are after.

 

[Fuji]

OOps, sorry.
Can you just delete the line

    myDir = ThisWorkbook.Path & "\"

Used for testing purpose...

 

[shah0101]

OOps, sorry.
Can you just delete the line

    myDir = ThisWorkbook.Path & "\"

Used for testing purpose...

Deleted the line.

It now brought the files from that particular folder (doesn't seem like all) and files from other folders as well.

 

[shah0101]

This brought many files, but these are totally different files which doesn't belong to this particular folder which we are after.

View attachment 119862

Like this:

 

[Fuji]

OOps, I'm terribly sorry...
Found the bug.
Can you try this one?

Sub test()
    Dim myDir$, wsName$, r As Range, s$, x&, myFile As Object, fso As Object, temp, msg$, ms$
    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
    ThisWorkbook.Sheets("Customers").[a1].CurrentRegion.Offset(1).ClearContents
    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 LCase$(fso.getextensionname(myFile.Name)) Like "xls*" Then
            If Not myFile.Name Like "~*" Then
                If myDir & myFile.Name <> ThisWorkbook.FullName Then
                    ms = ms & vbLf & myFile.Name
                    s = "'" & myDir & "[" & myFile.Name & "]" & wsName & "'!"
                    temp = ExecuteExcel4Macro(s & "r1c1")
                    If IsError(temp) Then
                        msg = msg & vbLf & myFile.Name
                    Else
                        s = s & 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
                End If
            End If
        End If
    Next
    If Len(ms) Then MsgBox "Found;" & vbLf & ms
    If Len(msg) Then MsgBox "Foolowing file has no sheet named " & wsName & vbLf & msg
    Application.ScreenUpdating = True
End Sub