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

 

[mumps]

The problem I have is that I can't duplicate the error. The macro works properly with the 2 files you uploaded. It looks like the file "55557.xlsm" is being opened and that the sheet "CC" does exist in that file. Is "55557.xlsm" the first file the macro opens or are other files opened and the range is copied without errors before that one? If it's the first file that is opened then please upload it and attach the link here so I can try it out to see if it gives me an error. By the way, please use the "Reply" button instead of the "Reply with Quote" button. This avoids unnecessary clutter.

 

[ryansm05]

I've created two very basic excel files. Please note that the tab name is now CC and not C&C.

https://www.dropbox.com/s/009kbdel20b0fun/55557.xlsm?dl=0
https://www.dropbox.com/s/dow7x8xw7vqopsv/55558.xlsm?dl=0

Thanks

 

[mumps]

The macro worked perfectly using the previous 2 files and the last 2 files you uploaded. The data from all 4 files was imported and sorted properly. I'm wondering if the macro "MonkeyNuts" which is called when a source workbook is opened is causing the problem. I have removed the macro from the source workbook. Maybe you can try that.

 

[ryansm05]

The reason I created these 2 new files was because I wondered the exact same thing - but the MonkeyNuts code has been deleted from the two files I shared with you.

Can you perhaps share the summary file and the 4 imported files that you had working? I can then look at using these and then adapting.

Thanks

 

[mumps]

Here you go!
https://app.box.com/s/4hxjbfoqemklzkaqvftn5ojlgvv5xa3o
https://app.box.com/s/yjxm2f62hvu6d9y6t8hiexsnw7ntzpuy
https://app.box.com/s/1uffzjf3ksg1jnft27zuoauhzocccvs2
https://app.box.com/s/aqkqt9wek3olrpfmft11av207paw2kvo
https://app.box.com/s/ksu1exq4akdgwiqijgb20ka95vk1b75j

Please let me know how they work out.

 

[NdNoviceHlp]

This may be the DIR function producing unexpected results. Here's an untested file system object version. HTH. Dave

Option Explicit
Sub test()
Dim LastRow As Double, sht As Worksheet, FSO As Object
Dim FlDr As Object, FileNm As Object
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
With ThisWorkbook.Sheets("TAB1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F24:AK24").Copy
ThisWorkbook.Sheets("TAB1").Cells(LastRow + 1, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
With ThisWorkbook.Sheets("TAB1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F29:AK29").Copy
ThisWorkbook.Sheets("TAB1").Cells(LastRow + 1, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
Sheets("TAB1").Rows(1).EntireRow.Delete
    LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("TAB1").Sort.SortFields.Clear
    Sheets("TAB1").Sort.SortFields.Add Key:=Range("A1:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("TAB1").Sort
        .SetRange Range("A1:A" & 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

Please note that I'm sure there's a better way to locate your inputted data than repeatedly using lastrow as I have but I'm not real clear on where you want the data... all in "A"? That's where it's going. Good luck.

 

[ryansm05]

Hi Dave,

This is almost perfect but as you say, everything is going in A. Instead, can I get this data (exported from F24:AK24 & F29:AK29) to A1:AF1 & A2:AF2 and then every additional file will go in the next available row?

Also, is there a way to make this macro run when opening the file?

Thanks again and sorry to be a pain. It's so close to being exactly how I need it.

Ryan

 

[NdNoviceHlp]

Untested but looks like it should work but I'm not sure about the sort part....

Option Explicit
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
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 _
    Destination:=ThisWorkbook.Sheets("TAB1").Cells(Cnt, "A")
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F29:AK29").Copy _
    Destination:=ThisWorkbook.Sheets("TAB1").Cells(Cnt, "A")
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
Sheets("TAB1").Rows(1).EntireRow.Delete
    LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Sheets("TAB1").Sort.SortFields.Clear
    Sheets("TAB1").Sort.SortFields.Add Key:=Range("A1:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("TAB1").Sort
        .SetRange Range("A1:A" & 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

In the workbook open event...

Call Test

HTH. Dave

 

[ryansm05]

Hi Dave,

This works but again there are a few problems:

1) The macro is only working if the values are hard-coded. Since they were originally formula driven (and will be in my report), it REFd out. However, when hard-coding them the values pulled through correctly.

2) After hard-coding 1) I ran the macro via the code with F8 and I saw it pull through all the required information (F24:AK24 & F29:AK29) for both reports. So I had 4 rows which was correct.

However, when passing through this piece of code via the F8 function for the final time, it deleted the first line and left me with only 3 rows.

Sheets("TAB1").Rows(1).EntireRow.Delete
    LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

 

[NdNoviceHlp]

Trial again...

Option Explicit
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
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, "A").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F29:AK29").Copy
ThisWorkbook.Sheets("TAB1").Cells(Cnt, "A").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("A1:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("TAB1").Sort
.SetRange Range("A1:A" & 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

Dave