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.

 

[NdNoviceHlp]

Hi shah0101. It's raining and it seems like I have time to mess round with some code. My trial seemed to work for this code. The code Resizes the range instead of copying it. Not clear on your range... B53:O153 a large range or did U want only B53:O53? Your file search for "*xlsm*" will only get .xlsm files... is this what you want? Also, your folder path was missing the backslash. Anyways, give this a whirl. HTH. Dave

Sub CopyValuesFromFiles()
Dim sourceFolder As String
Dim sourceFiles As Object
Dim sourceFile As Object
Dim WbSource As Workbook
Dim wsDestination As Worksheet
Dim Rng As Range, LastRow As Integer

On Error GoTo ErFix
Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Customers")

' Set the path to the source folder modify accordingly
sourceFolder = "Z:\DOCUMENTS\INVOICES- 24-25\"
' 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
Set Rng = WbSource.Worksheets(1).Range("B53:O153")

With wsDestination
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' Paste the values to the destination worksheet
'wsDestination.Range("A" & destinationRow).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
wsDestination.Range("A" & LastRow + 1).Resize(Rng.Rows.Count, _
                       Rng.Columns.Count).Cells.Value = Rng.Cells.Value

' Close the source workbook without saving changes
WbSource.Close savechanges:=False
End If
Next sourceFile

ErFix:
If Err.Number <> 0 Then
MsgBox "Error"
Else
' Display a message when the copying is complete
MsgBox "Copying customer information from files complete."
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set sourceFiles = Nothing
End Sub

ps. Please use code tags

 

[shah0101]

Hi shah0101. It's raining and it seems like I have time to mess round with some code. My trial seemed to work for this code. The code Resizes the range instead of copying it. Not clear on your range... B53:O153 a large range or did U want only B53:O53? Your file search for "*xlsm*" will only get .xlsm files... is this what you want? Also, your folder path was missing the backslash. Anyways, give this a whirl. HTH. Dave

Sub CopyValuesFromFiles()
Dim sourceFolder As String
Dim sourceFiles As Object
Dim sourceFile As Object
Dim WbSource As Workbook
Dim wsDestination As Worksheet
Dim Rng As Range, LastRow As Integer

On Error GoTo ErFix
Application.ScreenUpdating = False
Application.DisplayAlerts = False

' Set the destination worksheet modify sheet name accordingly
Set wsDestination = ThisWorkbook.Worksheets("Customers")

' Set the path to the source folder modify accordingly
sourceFolder = "Z:\DOCUMENTS\INVOICES- 24-25\"
' 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
Set Rng = WbSource.Worksheets(1).Range("B53:O153")

With wsDestination
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' Paste the values to the destination worksheet
'wsDestination.Range("A" & destinationRow).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
wsDestination.Range("A" & LastRow + 1).Resize(Rng.Rows.Count, _
                       Rng.Columns.Count).Cells.Value = Rng.Cells.Value

' Close the source workbook without saving changes
WbSource.Close savechanges:=False
End If
Next sourceFile

ErFix:
If Err.Number <> 0 Then
MsgBox "Error"
Else
' Display a message when the copying is complete
MsgBox "Copying customer information from files complete."
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set sourceFiles = Nothing
End Sub

ps. Please use code tags

Thanks for your time Dave,

Tried your code just now, returned attached error for me.

B53:O153 is the range in all files from where I need to gather the data and append in to new file. There is one more field "B2", which I need to fetch with the data in B53:O153.


I was googling the same since yesterday and I stumbled upon following, can you have a look and advise how to properly narrate it because I tried it and it didn't work either.

quote

1. Obtain a list of files (including paths) you want to extract from. On Windows you select them all in the file explorer, hold shift and right-click, then select "Copy as path". (On other operating systems I would suggest using the ls command.)

2. Put this list into an Excel spreadsheet and separate the paths into column A and the filenames into column B. (A formula could do this part as well.)

3. Then in C1 write a formula like: =INDIRECT("'"&A1&"["&B1&"]Sheet1'!$B$4")

unquote


I didn't mentioned it earlier, the files in the folder are used frequently by other users so I have to ask everybody to close all files in the folder while I am running any query or code and also the files in this folder keeps on adding on a daily basis so is it possible to run any kind of background query or something quietly and not to disturb other users?

Thanks in advance.

Looking forward for your guidance please.

 

[kvsrinivasamurthy]

Change this line

destinationRow = destinationRow + 1

as

destinationRow = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

 

[shah0101]

Change this line

destinationRow = destinationRow + 1

as

destinationRow = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

DEAR @kvsrinivasamurthy

Thanks for your time.

Ran the code with your suggestion, which took the total time of 47 minutes, and during that time I had to ask every colleague of mine to not to use that folder.

The result is also not satisfactory, all the data from rows went in columns and column data went in rows (basically transposed), if I start to transpose each file data it will take longer time then to copy and paste data from each and every single file.

Can you suggest any time effective and simpler solution please?

As I mentioned above, 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, Task is still the same, gather data from range "B53:O153" + one filed "B2" from hundreds of files in one folder either by power query, vba script, any built in function like =indirect or something experts like you recommend.

Thanks in advance!

 

[kvsrinivasamurthy]

Change this
Transpose:=True
As
Transpose:=False

 

[NdNoviceHlp]

shah101 comment out (remove the line)...

On Error GoTo ErFix

and see what line of code errors. I mocked up some trial wbs before I posted and the code worked fine for me. You should also comment out the lines...

Application.ScreenUpdating = False
Application.DisplayAlerts = False

until the code is error free. Getting the B2 value transported isn't that hard.... where do you want to put it? Dave
ps. copy/paste is slow.

 

[shah0101]

shah101 comment out (remove the line)...

On Error GoTo ErFix

and see what line of code errors. I mocked up some trial wbs before I posted and the code worked fine for me. You should also comment out the lines...

Application.ScreenUpdating = False
Application.DisplayAlerts = False

until the code is error free. Getting the B2 value transported isn't that hard.... where do you want to put it? Dave
ps. copy/paste is slow.

Thank you @NdNoviceHlp & @kvsrinivasamurthy Really appreciate your help, Thanks.

I tried the code of my very first post with changes @kvsrinivasamurthy suggested and it worked fine but it again took almost an hour to get the data and more drawbacks are (1) i can't use my computer because the code is using copy and paste (2) my colleagues can not use that folder to add, edit, delete the files in the folder.

Ideally if "B2" value can copied in the left cell of B53:O153 range repeatedly, that would be great.

Any faster power query, vba script, any built in function like =indirect is possibility?

I can't thank you both enough!

Thanks.

 

[NdNoviceHlp]

There is no left of "A" which is where your code was placing the transferred range? I've already prepared some faster code but you need to indicate where the error is in the current code by following my previous instructions. Dave

 

[kvsrinivasamurthy]

I have done changes in your code by adding dictionary. Try.

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
Dim T&, Ta&

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

With CreateObject("scripting.dictionary")

' 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)
T = T + 1
' Copy the values from B53 to O153
.Add T, wbSource.Worksheets(1).Range("B53:O153")

' Paste the values to the destination worksheet
'wsDestination.Range("A" & destinationRow).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

' Update the destination row for the next set of values
'destinationRow = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

' Close the source workbook without saving changes
wbSource.Close SaveChanges:=False
End If
Next sourceFile

For Ta = 1 To T
wsDestination.Range("A" & destinationRow).Resize(101, 14) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(Ta)))
destinationRow = destinationRow + 101
Next Ta
' 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