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:
OOps, I'm terribly sorry...
Found the bug.
Can you try this one?
Code: 
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
Click to expand...

1732969833321.png



1732969911027.png




1732969968613.png



1732970028608.png



1732970070466.png





1732970113708.png
 
Upvote 0

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
What is the name of output sheet?

I took it from your original code.
Rich (BB code): 
' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Customers")
 
Upvote 0
Fuji said:
What is the name of output sheet?

I took it from your original code.
Rich (BB code): 
' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Customers")
Click to expand...

I changed the destination worksheet name as "Customers"

Now its opening the dialog box and asking to select each file one by one. Can't it run in background without asking me which file to select please?
 
Upvote 0
Strange, you should not see such dialog.
Is it asking you to select "Data Entry" sheet?

The code should ignore the file(s) that has no "Data Entry" sheet, means output only the workbook(s) that have "Data Entry" sheet...


WAIT.

I see myDir is just a period "." in the local window.
 
Last edited:
Upvote 0
Fuji said:
Strange, you should not see such dialog.
Is it asking you to select "Data Entry" sheet?

The code should ignore the file(s) that has no "Data Entry" sheet, means output only the workbook(s) that have "Data Entry" sheet...


WAIT.

I see myDir is just a period "." in the local window.
Click to expand...
Not the "Data Entry" sheet, the workbook selection dialog for every file.
 
Upvote 0
Alex was right...
I see myDir = "." in your local window.

Try this one.
Code: 
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\"
    Set r = [B53:O153]: wsName = "Data Entry"
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Customers").[a1].CurrentRegion.Offset(1).ClearContents
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(myDir) Then MsgBox "Wrong Folder path": Exit Sub
    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
 
Upvote 0
Fuji said:
Alex was right...
I see myDir = "." in your local window.

Try this one.
Code: 
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\"
    Set r = [B53:O153]: wsName = "Data Entry"
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Customers").[a1].CurrentRegion.Offset(1).ClearContents
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(myDir) Then MsgBox "Wrong Folder path": Exit Sub
    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
Click to expand...



1732972640300.png



1732972693880.png
 
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,296
Messages
6,177,741
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