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.

 

[kvsrinivasamurthy]

Code modified.

Sub n()
Dim wsDestination As Worksheet
'set destinationRow
destinationRow = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
End Sub
Sub m()
With CreateObject("scripting.dictionary")
.Add 1, Range("A4:B8")
.Add 2, 200
Range("D4:E8") = WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Item(1)))
Range("a10") = .Item(2)
End With
End Sub

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

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

 

[shah0101]

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

Thanks for your help Dave @NdNoviceHlp,

Just tried the code again below are two results:

The field "B1" (not "B2") & "B15" (am I getting greedy and now ) which I need to bring up with the data on B53:O153, if can be repeated on right side of the pulled up data. that would be great.


Thanks again and in advance.

 

[kvsrinivasamurthy]

Try the code in post#11

 

[shah0101]

Try the code in post#11

Dear @kvsrinivasamurthy

Tried it just now and it returned error as below:

 

[kvsrinivasamurthy]

Pl check sheet name is Customers is there or changed. This is your original program line. I have not changed.

 

[shah0101]

Pl check sheet name is Customers is there or changed. This is your original program line. I have not changed.

Ye, its there. I tried saving it as macro enabled file then regular excel file but unable to figure out what is wrong.

 

[kvsrinivasamurthy]

There was mistake. Corrected code is here . Pl 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

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

 

[shah0101]

There was mistake. Corrected code is here . Pl 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

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

Still returning same error!

 

[Alex Blakenburg]

Is the Sheet Customers in the same workbook that contains the code ?

 

[shah0101]

Is the Sheet Customers in the same workbook that contains the code ?

Yes, @Alex Blakenburg , its there: