Loop Through Formula/Macro

R

ryansm05

Board Regular
Joined
Sep 14, 2016
Messages
148
Office Version
  1. 365
Platform
  1. Windows
Hi,

I need a formula or macro that can loop through a particular file and return specified cells from EVERY file saved in this location (up to say 2,000 potential files). Furthermore, I'll need this formula / macro to sore the data alphabetically by client.

For a little more context, I'm needing to create a summary sheet for 100s of jobs that will be saved in a specific file location by project managers.

If anyone could help, I would be extremely grateful and in total awe.

Thanks
Ryan
 
Sort by date Sort by votes
Dave - just wanted to update you in that the sheet is working wonderfully, and when asked how I managed to do this, "some guy from Canada on a forum - named Dave", has been given full credit :)

However, just a quick question regarding the time it takes to run this macro. I understand it's opening up as many sheets that are saved into the file location. For 3/4 files it's take perhaps 5/6 seconds and for up to 10 files it's taking around 8-12 seconds.

My only concern is that when the number of files reaches 100+ that it becomes unusable. With this in mind, do you have any recommendations of speeding up the process without changing the code (as it works perfect!).

Thanks as always!
Ryan
 
Upvote 0

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Hi Ryan and thanks for the update. U can trial...
Code: 
Application.EnableEvents= False
Application.DisplayAlerts = False
 Application.ScreenUpdating = False
then...
Code: 
Application.EnableEvents= True
Application.DisplayAlerts = True
 Application.ScreenUpdating = True
Don't forget to update the error part of the code as well. I have no idea if this will speed it up (or if the code will even work anymore). It seems like it's taking a bit more than a second per file. 100 files may take 2 mins or less... that's not very long compared to the "hours" that I've seen posted here for some routines to run. U could put...
Application.cursor = xlwait at the start of the code then Application.Cursor = xlDefault at the end (again don't forget to include in the error part of the code)… this will let the user know that XL is doing something. HTH. Dave
 
Upvote 0
Dave I've updated as below and it's probably running at the same speed (which is fine when I think about it), but the application to let the user know it is doing something isn't working - so maybe I've done the last part wrong?

However, I decided to increase the volume of files to see how the macro responds and it seems anything over 20 files causes it to crash. Nevertheless, it will then reboot as 'Summary (recovered)' and manages to pull all the data through correctly (I've tested it with up to 132 files).
My only worry is that when the file crashes in future, the macro may become unresponsive and the 'Summary (recovered)' also fails. Have you ever come across this before and do you have any advice? I only ask as I'm using this to change a departments financial processes so I'm worried that it'll create a lot of issues in the future.

Thanks for your help as always.

Sub test()Dim LastRow As Double, sht As Worksheet, FSO As Object
Dim FlDr As Object, FileNm As Object, Cnt As Integer
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files")
Application.Cursor = xlWait
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Cnt = 4
ThisWorkbook.Sheets("TAB1").Range("D4:AJ1000").ClearContents
For Each FileNm In FlDr.Files
If FileNm.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "CC" Then
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("E25:AK25").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("E40:AK40").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("TAB1").Sort.SortFields.Clear
Sheets("TAB1").Sort.SortFields.Add Key:=Range("D5:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("TAB1").Sort
.SetRange Range("D5:AJ" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
End Sub
Private Sub Workbook_Open()
Call test
End Sub
Click to expand...
 
Upvote 0
Not sure why the cursor thing doesn't work. I suspect it's the enable events... get rid of it and trial controlling the calculations as follows. U also don't have the error directions in your code. Let me know if it continues to crash. It shouldn't? Dave
Code: 
On Error GoTo Erfix
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.Cursor = xlWait

Code: 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Don't forget to change the error code as well. Dave
 
Upvote 0
what do you mean by the error directions? I thought I had done this correctly with the red text below?
Now it seems to take even longer before crashing (with 132 files) ... and still no cursor thing :( I must have done the code wrong!?


Sub test()Dim LastRow As Double, sht As Worksheet, FSO As Object
Dim FlDr As Object, FileNm As Object, Cnt As Integer
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files")
On Error GoTo Erfix
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.Cursor = xlWait
Cnt = 4
ThisWorkbook.Sheets("TAB1").Range("D4:AJ1000").ClearContents
For Each FileNm In FlDr.Files
If FileNm.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "CC" Then
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("E25:AK25").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("E40:AK40").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("TAB1").Sort.SortFields.Clear
Sheets("TAB1").Sort.SortFields.Add Key:=Range("D5:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("TAB1").Sort
.SetRange Range("D5:AJ" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
End Sub
Private Sub Workbook_Open()
Call test
End Sub
Click to expand...
 
Upvote 0
Your code was missing the ….
Code: 
On Error GoTo Erfix
which tells the code to use the error resolution code ErFix. So if U miss that line, your error code won't work. Anyways, I've some suggestion to resolve the error. Let's test some code. Dave
Code: 
Sub test()
Dim LastRow As Double, sht As Worksheet, FSO As Object
 Dim FlDr As Object, FileNm As Object, Cnt As Integer
 On Error GoTo Erfix
 Application.Cursor = xlWait
 ThisWorkbook.Sheets("TAB1").Range("D4:AJ1000").ClearContents
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Cnt = 4
  Set FSO = CreateObject("scripting.filesystemobject")
 '***change Folder path/name to your folder path/name
 Set FlDr = FSO.GetFolder("I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files")
 For Each FileNm In FlDr.Files
 If FileNm.Name Like "*.xlsm" Then
 Workbooks.Open Filename:=FileNm
 For Each sht In Workbooks(FileNm.Name).Sheets
 If sht.Name = "CC" Then
 Cnt = Cnt + 1
 Workbooks(FileNm.Name).Sheets(sht.Name).Range("E25:AK25").Copy
 ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 Cnt = Cnt + 1
 Workbooks(FileNm.Name).Sheets(sht.Name).Range("E40:AK40").Copy
 ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 Exit For
 End If
 Next sht
 Workbooks(FileNm.Name).Close SaveChanges:=False
 End If
 Next FileNm
 
 MsgBox "Finished Files"
 
 LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Sheets("TAB1").Sort.SortFields.Clear
 Sheets("TAB1").Sort.SortFields.Add Key:=Range("D5:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With Sheets("TAB1").Sort
 .SetRange Range("D5:AJ" & LastRow)
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Application.Calculation = xlAutomatic
 Application.Cursor = xlDefault
 Set FlDr = Nothing
 Set FSO = Nothing
 Exit Sub
Erfix:
 On Error GoTo 0
 MsgBox "Error"
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Application.Calculation = xlAutomatic
 Application.Cursor = xlDefault
 Set FlDr = Nothing
 Set FSO = Nothing
 End Sub
 
Upvote 0
Right I've just given this is a go - and it works correctly with a smaller number of files and displays a message to let you know it's 'complete'. Perfect!

However, when trying this with around 100 files, it will pull in the information for about 95% of them but then displays an 'error' message - in the same format as the 'complete' above.

I updated the file path as you highlighted so I'm not too sure why this won't work.

Nevertheless, it's Christmas and so please do not rush back with further suggestions - this can wait! Have a great day tomorrow and hopefully we can resume when you next get a chance :)

Merry Christmas, Dave!

Ryan
 
Upvote 0
Hi Ryan. Your testing results indicate that it's likely that your clipboard is causing the error. The "complete" message box is included just to indicate where the error is occurring. Trial this...
Add a module and paste in this code...
Rich (BB code): 
#If VBA7 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else 
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
#End  If
Then your new code...
Rich (BB code): 
Option Explicit
Sub test()
Dim LastRow As Double, sht As Worksheet, FSO As Object
 Dim FlDr As Object, FileNm As Object, Cnt As Integer
 On Error GoTo Erfix
 Application.Cursor = xlWait
 ThisWorkbook.Sheets("TAB1").Range("D4:AJ1000").ClearContents
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Cnt = 4
  Set FSO = CreateObject("scripting.filesystemobject")
 '***change Folder path/name to your folder path/name
 Set FlDr = FSO.GetFolder("I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files")
 For Each FileNm In FlDr.Files
 If FileNm.Name Like "*.xlsm" Then
 Workbooks.Open Filename:=FileNm
 For Each sht In Workbooks(FileNm.Name).Sheets
 If sht.Name = "CC" Then
 Cnt = Cnt + 1
 Workbooks(FileNm.Name).Sheets(sht.Name).Range("E25:AK25").Copy
 ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 Cnt = Cnt + 1
 Workbooks(FileNm.Name).Sheets(sht.Name).Range("E40:AK40").Copy
 ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 OpenClipboard (0&)
 EmptyClipboard
 CloseClipboard
 Exit For
 End If
 Next sht
 Workbooks(FileNm.Name).Close SaveChanges:=False
 End If
 Next FileNm
 
 MsgBox "Finished Files"
 
 LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Sheets("TAB1").Sort.SortFields.Clear
 Sheets("TAB1").Sort.SortFields.Add Key:=Range("D5:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With Sheets("TAB1").Sort
 .SetRange Range("D5:AJ" & LastRow)
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Application.Calculation = xlAutomatic
 Application.Cursor = xlDefault
 Set FlDr = Nothing
 Set FSO = Nothing
 Exit Sub
Erfix:
 On Error GoTo 0
 MsgBox "Error"
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 Application.Calculation = xlAutomatic
 Application.Cursor = xlDefault
 Set FlDr = Nothing
 Set FSO = Nothing
 End Sub
If all goes well U can remove the "complete" msgbox line of code... it's just there for testing. Have a great holiday season. Dave
ps. the "complete" msgbox actually says "Finished Files"
 
Last edited:
Upvote 0
Right - so I've just tested this and it works perfectly. The 'Finished Files' box is fine and I'm happy for this to stay.

Everything worked as planned, and for 194 files it took 28 minutes but pulled through the data correctly. However, when running just 40 files it takes less than 2 minutes. Given that I'll probably only ever use up to 100 files - this works great.

All that is left to say is have a great 2019 and thanks again for all your amazing work.

Cheers!
Ryan
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
362
glynn1969
G
Y
  • Question
Modify Macro to Select 1 .TXT File at a time, do changes on it (tab delimeter+column to text) to convert to .XLS file+save the file then select other
Replies
0
Views
371
yferrer
Y
M
  • Solved
Looping through creating workbooks and saving them based on a range
Replies
2
Views
359
MrJamesS
M
B
  • Solved
VBA to save one file as multiple files in location
Replies
7
Views
635
bh24524
B
B
  • Locked
  • Question
Find and Replace WB references (VBA)
Replies
7
Views
640
RoryA
RoryA

Forum statistics

Threads
1,214,929
Messages
6,122,317
Members
449,081
Latest member
tanurai

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