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]

Code is working ok in Excel. I do not know about google sheets.

And which code you are referring to please?

 

[NdNoviceHlp]

I don't recall any mention of Google sheets? A quote from this link .... Can Google Sheets Use VBA - Nathaniel Kam
"Google Sheets cannot use VBA, Visual Basic for Applications. Google Sheets uses Google Apps Script.."
I trialed downloading your wb and then it saved to somewhere I can't find on One Drive before I had any input into the matter? Anyways, I'm guessing if your wb is not an Excel wb, a VBA solution won't be useful. Apologies, as I will not be able to assist with Google App Script. Good luck. Dave
edit: I reviewed your posts and it seems like U are using XL. Not sure why you posted a Google sheet? Anyways, did U trial renaming the "Customer" sheet?

 

[shah0101]

I don't recall any mention of Google sheets? A quote from this link .... Can Google Sheets Use VBA - Nathaniel Kam
"Google Sheets cannot use VBA, Visual Basic for Applications. Google Sheets uses Google Apps Script.."
I trialed downloading your wb and then it saved to somewhere I can't find on One Drive before I had any input into the matter? Anyways, I'm guessing if your wb is not an Excel wb, a VBA solution won't be useful. Apologies, as I will not be able to assist with Google App Script. Good luck. Dave
edit: I reviewed your posts and it seems like U are using XL. Not sure why you posted a Google sheet? Anyways, did U trial renaming the "Customer" sheet?

I didn’t used google sheets. I uploaded the Excel 2021 file to google drive

 

[NdNoviceHlp]

Good old Google... converted it to a Google sheet. Anyways, I reviewed some One Drive code and if the wb is stored on One Drive then you have to use ActiveWorkbook not ThisWorkbook. So that line of code should be...

Set wsDestination = ActiveWorkbook.Worksheets("Customers")

Again, trial renaming the sheet to "Customers" just to mak sure there are no hidden spaces in the sheet name. Dave

 

[kvsrinivasamurthy]

I am having 2019 only.

 

[shah0101]

I changed the destination worksheet name from "Customers" to "Sheet1" and its started working but it got stucked at:

The Code I used is as below::

=======================
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("Sheet1")

' 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

End With
' 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



===================

Any thoughts please?

 

[kvsrinivasamurthy]

Try
Change

wsDestination.Range("A" & destinationRow).Resize(101, 14) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(Ta)))

as

wsDestination.Range("A" & destinationRow).Resize(101, 14) = Application.Transpose(Application.Transpose(.Item(Ta)))

 

[shah0101]

Try
Change

wsDestination.Range("A" & destinationRow).Resize(101, 14) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(Ta)))

as

wsDestination.Range("A" & destinationRow).Resize(101, 14) = Application.Transpose(Application.Transpose(.Item(Ta)))

Tried yet again and following is the result:

Is it possible to run any background Power Query please instead of running code and ask all colleagues to stop using the folder and files please?

 

[kvsrinivasamurthy]

Change this line

wsDestination.Range("A" & destinationRow).Resize(101, 14) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(Ta)))

as

wsDestination.Range("A" & destinationRow).Resize(101, 14) = .Item(Ta)

 

[shah0101]

Change this line

wsDestination.Range("A" & destinationRow).Resize(101, 14) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(Ta)))

as

wsDestination.Range("A" & destinationRow).Resize(101, 14) = .Item(Ta)

Still not working same error as previous post.


Is it possible to run any background Power Query please instead of running code and ask all colleagues to stop using the folder and files please? Task is still the same bring up range: B53:O153 + Cell "B1" + Cell "B15" from hundreds of files lying in the same folder.

Please!

Thanks in advance.