Loop Through Formula/Macro

[ryansm05]

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

 

[ryansm05]

Dave,

The working day here has finished in the UK and I've tested just as I was leaving.

I am amazed to say it works as needed and that your knowledge of Excel and macro's is incredible. A massive thanks to you and Mumps for your help with this.

The only adjustment I would need is that it runs automatically when opened (because it will be used by people with very minimal excel skills). However, if this is not possible, I'm sure I could manage without.

Thanks again and all the best,
Ryan

 

[NdNoviceHlp]

Ryan you are welcome. As mentioned in my previous post...

Private Sub Workbook_Open()
Call Test
End Sub

Have a nice day. Dave

 

[ryansm05]

Hi Dave.

If I want to adjust the row where the data extracts to (I've changed the column to D), what piece of code will I need to amend? For example, I want this to extract starting from row 4 (D4)...

Thanks
Ryan

Option ExplicitSub 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.ScreenUpdating = False
Application.DisplayAlerts = False
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("F24:AK24").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F29:AK29").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("D1:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("TAB1").Sort
.SetRange Range("D1:D" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub


Private Sub Workbook_Open()
Call test
End Sub

 

[NdNoviceHlp]

Application.DisplayAlerts = False
Cnt = 3
 For Each FileNm In FlDr.Files
'and....
Sheets("TAB1").Sort.SortFields.Add Key:=Range("D4:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With Sheets("TAB1").Sort
 .SetRange Range("D4:D" & LastRow)

HTH. Dave

 

[ryansm05]

Almost there Dave, but I've noticed that when sorting by column D ... it's only sorting the data in this column.

What I'm needing is to sort the rows based on column D values. I hope this make sense? Let me know if it does not.

Thanks
Ryan

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.ScreenUpdating = False
Application.DisplayAlerts = False
Cnt = 4
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("F24:AK24").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F29:AK29").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "D").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F40: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:D" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set FlDr = Nothing
Set FSO = Nothing
End Sub


Private Sub Workbook_Open()
Call test
End Sub

 

[NdNoviceHlp]

Yes that never did see right before. Just change the "H" in the code below to the column you want. Dave

 With Sheets("TAB1").Sort
 .SetRange Range("D4:H" & LastRow)

 

[ryansm05]

Dave you are a legend!

I'm now going to build out my report in the next week or so and maybe I'll have a few more questions regarding how I can adapt this - I hope you don't mind.

However, in the mean time, is there anyway I can pay you back for your help? Perhaps you have a charity that you support and I can make a donation to as I would never have been able to do this without your expertise.

Thanks
Ryan!

Thanks
Ryan

 

[ryansm05]

Actually Dave there is one small issue I've just encountered: the macro is unable to clear old data.

By this I mean, I may run the macro based on two files being saved in the specified location. The macro will return data from these two files which is correct. I can then change data in these ranges and re-run the macro, and it will update accordingly which is also correct.

However, if I happen to delete one of these files and re-run, the macro fails to remove the old data and instead it will remain. I appreciate I had not yet asked for this (because I had not foreseen this issue) - but if you have a workaround, it would be very helpful.

Ultimately, on the summary sheet, I need the macro to clear ranges D4:AI1000 before running the above code. Is this possible?

Thanks
Ryan

 

[NdNoviceHlp]

Cnt = 4
 ThisWorkbook.Sheets("TAB1").Range("D4:AI1000").ClearContents
For Each FileNm In FlDr.Files

Seems like the above should work. No need for compensation... just pass along some assistance to others here when you're able. I'll provide U further assistance if I'm able. Dave

 

[ryansm05]

Have a great weekend - much appreciated!