Gathering Data From Multiple Files in Same Folder in Particular Range

S

shah0101

Board Regular
Joined
Jul 4, 2019
Messages
175
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.
 
Sort by date Sort by votes
Fuji said:
Do you have Customers sheet as a destination sheet?
Click to expand...

Thank you, Thank you, Thank you, Thank you, sooooo much

It fetched the data

I can't thank you enough!! but still Thanks you soooo very much.

Couple of things please:
1) It is bringing up the file name with path and sheet name on top of each data set, can we remove that please?
1732977777616.png


2) Can I get a little bit greedy, is it possible to bring two cells "B1" & "B15" before the range "B53:O153" columns repeatedly to identify the data of each file. I mean each file has a unique number and name in "B1" & "B15" so the data in the range "B53:O153" can be identified, please?

Again, thank you sooo much.
 
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Do you want it separately?
I mean B1 in one cell and B15 in one cell or B1&B15 in one cell?
 
Upvote 0
OK, B1 in col.A & B15 in co.B on top of the data from each file.
Cleaned up a bit
You can change parameters in bold part as you wish.
Rich (BB code): 
Sub test()
    Dim s$, x&, n&, msg$, myFile As Object, fso As Object
    Dim wsDest As Worksheet, temp, r As Range
    Const wsName$ = "Data Entry", myName$ = "Customers"
    Const myDir$ = "Z:\DOCUMENTS\INVOICES- 24-25\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(myDir) Then MsgBox "Wrong Folder path", , myDir: Exit Sub
    If fso.GetFolder(myDir).Files.Count = 0 Then MsgBox "No files": Exit Sub
    If Not Evaluate("isref('" & myName & "'!a1)") Then ThisWorkbook.Sheets.Add.Name = myName
    Set wsDest = ThisWorkbook.Sheets(myName)
    wsDest.[a1].CurrentRegion.Offset(1).ClearContents
    Application.ScreenUpdating = False
    Set r = [B53:O153]
    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
                    n = n + 1
                    s = "'" & myDir & "[" & myFile.Name & "]" & wsName & "'!"
                    temp = ExecuteExcel4Macro(s & "r1c1")
                    If IsError(temp) Then
                        msg = msg & vbLf & myFile.Name
                    Else
                        With wsDest
                            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(, 2)
                                    .Formula = Array("=" & s & "B1", "=" & s & "B15")
                                    .Value = .Value
                                End With
                                s = s & r(1).Address(0, 0)
                                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
    Application.ScreenUpdating = True
    MsgBox "Found " & n & " Files" & IIf(Len(msg), vbLf & "Following file(s) donesn't have " & wsName, "")
End Sub
 
Upvote 0
Fuji said:
OK, B1 in col.A & B15 in co.B on top of the data from each file.
Cleaned up a bit
You can change parameters in bold part as you wish.
Rich (BB code): 
Sub test()
    Dim s$, x&, n&, msg$, myFile As Object, fso As Object
    Dim wsDest As Worksheet, temp, r As Range
    Const wsName$ = "Data Entry", myName$ = "Customers"
    Const myDir$ = "Z:\DOCUMENTS\INVOICES- 24-25\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(myDir) Then MsgBox "Wrong Folder path", , myDir: Exit Sub
    If fso.GetFolder(myDir).Files.Count = 0 Then MsgBox "No files": Exit Sub
    If Not Evaluate("isref('" & myName & "'!a1)") Then ThisWorkbook.Sheets.Add.Name = myName
    Set wsDest = ThisWorkbook.Sheets(myName)
    wsDest.[a1].CurrentRegion.Offset(1).ClearContents
    Application.ScreenUpdating = False
    Set r = [B53:O153]
    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
                    n = n + 1
                    s = "'" & myDir & "[" & myFile.Name & "]" & wsName & "'!"
                    temp = ExecuteExcel4Macro(s & "r1c1")
                    If IsError(temp) Then
                        msg = msg & vbLf & myFile.Name
                    Else
                        With wsDest
                            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(, 2)
                                    .Formula = Array("=" & s & "B1", "=" & s & "B15")
                                    .Value = .Value
                                End With
                                s = s & r(1).Address(0, 0)
                                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
    Application.ScreenUpdating = True
    MsgBox "Found " & n & " Files" & IIf(Len(msg), vbLf & "Following file(s) donesn't have " & wsName, "")
End Sub
Click to expand...

Thanks again Fuji,

Tried above':
1) It resulted with message box that "Found 399 Files" but the number of files is much more than that
1733029513399.png



2) Is it possible to bring "B1" and B15" side by side to the list range "B53:O153" like "B1" in A column, B15 in B column, then B53:O153 range starts from C column and "B1" and B15 keeps on repeating against records of same file. I am not sure if I am explaining it correctly.

Thanks a billion
 
Upvote 0
First, we need to find why there are missing files.
The below code will list all the files in selected folder and outputs the file names in Customers sheet from A1, so that count will be the last row in col.A.
If you find any files that is/are missing, please report.
Code: 
Sub CountAllFilesInFolder()
    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
        n = n + 1: myList(n, 1) = myFile.Name
    Next
    With Sheets("customers")
        .[a1].CurrentRegion.ClearContents
        .[a1].Resize(myFiles.Count) = myList
    End With
End Sub
 
Upvote 0
Fuji said:
First, we need to find why there are missing files.
The below code will list all the files in selected folder and outputs the file names in Customers sheet from A1, so that count will be the last row in col.A.
If you find any files that is/are missing, please report.
Code: 
Sub CountAllFilesInFolder()
    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
        n = n + 1: myList(n, 1) = myFile.Name
    Next
    With Sheets("customers")
        .[a1].CurrentRegion.ClearContents
        .[a1].Resize(myFiles.Count) = myList
    End With
End Sub
Click to expand...

this code is bringing up dialog box to select the files
 
Upvote 0
Correct, and you need to select the folder i,e, Z:\DOCUMENTS\INVOICES- 24-25
 
Upvote 0
Fuji said:
OK, B1 in col.A & B15 in co.B on top of the data from each file.
Cleaned up a bit
You can change parameters in bold part as you wish.
Rich (BB code): 
Sub test()
    Dim s$, x&, n&, msg$, myFile As Object, fso As Object
    Dim wsDest As Worksheet, temp, r As Range
    Const wsName$ = "Data Entry", myName$ = "Customers"
    Const myDir$ = "Z:\DOCUMENTS\INVOICES- 24-25\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(myDir) Then MsgBox "Wrong Folder path", , myDir: Exit Sub
    If fso.GetFolder(myDir).Files.Count = 0 Then MsgBox "No files": Exit Sub
    If Not Evaluate("isref('" & myName & "'!a1)") Then ThisWorkbook.Sheets.Add.Name = myName
    Set wsDest = ThisWorkbook.Sheets(myName)
    wsDest.[a1].CurrentRegion.Offset(1).ClearContents
    Application.ScreenUpdating = False
    Set r = [B53:O153]
    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
                    n = n + 1
                    s = "'" & myDir & "[" & myFile.Name & "]" & wsName & "'!"
                    temp = ExecuteExcel4Macro(s & "r1c1")
                    If IsError(temp) Then
                        msg = msg & vbLf & myFile.Name
                    Else
                        With wsDest
                            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(, 2)
                                    .Formula = Array("=" & s & "B1", "=" & s & "B15")
                                    .Value = .Value
                                End With
                                s = s & r(1).Address(0, 0)
                                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
    Application.ScreenUpdating = True
    MsgBox "Found " & n & " Files" & IIf(Len(msg), vbLf & "Following file(s) donesn't have " & wsName, "")
End Sub
Click to expand...

In addition to earlier request:
1) Is it possible to bring "B1" and B15" side by side to the list range "B53:O153" like "B1" in A column, B15 in B column, then B53:O153 range starts from C column and "B1" and B15 keeps on repeating against records of same file. I am not sure if I am explaining it correctly.

2) Is it possible to eliminate rows in "B53:O153" in which "B53 to B153" starts with a blank space " "?
 
Upvote 0
You must log in or register to reply here.

Similar threads

KlausW
  • Question Question
browse to folders and subfolders an copy cell
Replies
0
Views
392
KlausW
KlausW
KlausW
  • Solved
copy data from several closed workbooks to one workbook.
Replies
5
Views
1K
KlausW
KlausW
C
  • Solved
VBA - Copy Files with Prefix to Multiple Destinations Based on Cell Value
Replies
3
Views
472
ChaseHammer
C
H
  • Question Question
Amend Macro to limit Selection in C:\My Documents to Vat.*.xlsm
Replies
8
Views
495
howard
H
R
  • Solved
Loop through Rows
Replies
4
Views
363
rollingzep
R

Forum statistics

Threads
1,224,297
Messages
6,177,743
Members
452,797
Latest member
prophet4see

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top