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 then can you run the following code.
It outputs only the Excel files that is available, excludes file name starts with "~" etc.
And see if it outputs correctly?

Sub CountAllAvailableExcelFilesInFolder()
    Dim myDir$, n&, fso As Object, myFile As Object, myFiles As Object
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set myFiles = fso.GetFolder(myDir).Files
    If myFiles.Count = 0 Then MsgBox "No file": Exit Sub
    ReDim myList(1 To myFiles.Count, 1 To 1)
    For Each myFile In myFiles
        If (myDir & myFile.Name <> ThisWorkbook.FullName) * (Not myFile.Name Like "~*") * _
            (LCase$(fso.GetExtensionName(myFile.Name)) Like "xls*") Then
            n = n + 1: myList(n, 1) = myFile.Name
        End If
    Next
    With Sheets("customers")
        .[a1].CurrentRegion.ClearContents
        .[a1].Resize(myFiles.Count) = myList
    End With
End Sub

 

[shah0101]

OK then can you run the following code.
It outputs only the Excel files that is available, excludes file name starts with "~" etc.
And see if it outputs correctly?

Sub CountAllAvailableExcelFilesInFolder()
    Dim myDir$, n&, fso As Object, myFile As Object, myFiles As Object
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set myFiles = fso.GetFolder(myDir).Files
    If myFiles.Count = 0 Then MsgBox "No file": Exit Sub
    ReDim myList(1 To myFiles.Count, 1 To 1)
    For Each myFile In myFiles
        If (myDir & myFile.Name <> ThisWorkbook.FullName) * (Not myFile.Name Like "~*") * _
            (LCase$(fso.GetExtensionName(myFile.Name)) Like "xls*") Then
            n = n + 1: myList(n, 1) = myFile.Name
        End If
    Next
    With Sheets("customers")
        .[a1].CurrentRegion.ClearContents
        .[a1].Resize(myFiles.Count) = myList
    End With
End Sub

1) There are no files in the folder with "~" as all files are closed today
2) The file count is okay

 

[Fuji]

This is the modified code of my original code and stand alone, so no need to touch to the current code.

Sub testDir()
    Dim fn$, r As Range, s$, x&, n&, temp, msg$
    Const wsName$ = "Data Entry", myWs$ = "Customers"
    Const myDir$ = "Z:\DOCUMENTS\INVOICES- 24-25\"  '<--- Need path separator at the end
    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    Sheets(myWs).[a1].CurrentRegion.ClearContents
    Application.ScreenUpdating = False
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            s = "'" & myDir & "[" & fn & "]" & wsName & "'!"
            temp = ExecuteExcel4Macro(s & "r1c1")
            If Not IsError(temp) Then
                n = n + 1
                With ThisWorkbook.Sheets(myWs)
                    With Intersect(.UsedRange, .Columns("a").Resize(, r.Columns.Count))
                        x = .Parent.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))")
                    End With
                    With .Cells(x + 1, 1)
                        With .Resize(r.Rows.Count, 2)
                            .Formula = Array("=" & s & "$B$1", "=" & s & "$B$15")
                            .Value = .Value
                        End With
                        s = s & r.Cells(1).Address(0, 0)
                        With .Cells(1, 3).Resize(r.Rows.Count, r.Columns.Count)
                            .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                            .Value = .Value
                        End With
                    End With
                End With
            Else
                msg = msg & vbLf & fn
            End If
        End If
        fn = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Found " & n & " files" & IIf(Len(msg), vbLf & "Following file has no " & wsName & " sheet", "")
End Sub

If this doesn't outputs corrctly, I will combine the current code with CountAllAvailableExcelFilesInFolder with fixed folder(no need to select folder)

 

[shah0101]

This is the modified code of my original code and stand alone, so no need to touch to the current code.

Sub testDir()
    Dim fn$, r As Range, s$, x&, n&, temp, msg$
    Const wsName$ = "Data Entry", myWs$ = "Customers"
    Const myDir$ = "Z:\DOCUMENTS\INVOICES- 24-25\"  '<--- Need path separator at the end
    fn = Dir(myDir & "*.xls*"): Set r = [B53:O153]
    Sheets(myWs).[a1].CurrentRegion.ClearContents
    Application.ScreenUpdating = False
    Do While fn <> ""
        If myDir & fn <> ThisWorkbook.FullName Then
            s = "'" & myDir & "[" & fn & "]" & wsName & "'!"
            temp = ExecuteExcel4Macro(s & "r1c1")
            If Not IsError(temp) Then
                n = n + 1
                With ThisWorkbook.Sheets(myWs)
                    With Intersect(.UsedRange, .Columns("a").Resize(, r.Columns.Count))
                        x = .Parent.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))")
                    End With
                    With .Cells(x + 1, 1)
                        With .Resize(r.Rows.Count, 2)
                            .Formula = Array("=" & s & "$B$1", "=" & s & "$B$15")
                            .Value = .Value
                        End With
                        s = s & r.Cells(1).Address(0, 0)
                        With .Cells(1, 3).Resize(r.Rows.Count, r.Columns.Count)
                            .Formula = Replace("=if(#<>"""",#,"""")", "#", s)
                            .Value = .Value
                        End With
                    End With
                End With
            Else
                msg = msg & vbLf & fn
            End If
        End If
        fn = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Found " & n & " files" & IIf(Len(msg), vbLf & "Following file has no " & wsName & " sheet", "")
End Sub

If this doesn't outputs corrctly, I will combine the current code with CountAllAvailableExcelFilesInFolder with fixed folder(no need to select folder)

Thank you sooo much. I think it worked just fine.
Again thank you thank you thank you sooo much

 

[Fuji]

You are welcome.
I normally use Dir function instead of FileSystemObject for this kind of problem since it needs extra work sometime like this.

 

[shah0101]

You are welcome.
I normally use Dir function instead of FileSystemObject for this kind of problem since it needs extra work sometime like this.

Again, thank you very much.