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]

This macro will open the files and copy the ranges. I have left out the part of the code that does the sorting. You said that you wanted to sort based on column A of TAB1. The problem is that the formulas in your source files are returning blank cells for column F. Therefore, when the range is pasted in column A of TAB1, there is no data in column A to use as a sort reference. Your thoughts?

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, wsDest As Worksheet, wsSrc As Worksheet, lastRow As Long
    Set wsDest = ThisWorkbook.Sheets("TAB1")
    Const strPath As String = "I:\Accounts\2018\Financial Reporting\BRD\NewRev\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSrc = Sheets("C&C")
            wsSrc.Range("F24:AK24").Copy
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wsSrc.Range("F29:AK29").Copy
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Sheets("TAB1").Rows(1).EntireRow.Delete
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[ryansm05]

Hi Mumps,

I've tried this and it not does pull through any data? I've updated the code in red so that it is representative of my file paths / cell ranges for you to check. F8 runs through and completes with no error.

I'm assuming you got it to work for you? Is there anything I may be doing wrong?

Sub CopyRange() Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wkbSource As Workbook, wsDest As Worksheet, wsSrc As Worksheet, lastRow As Long
Set wsDest = ThisWorkbook.Sheets("TAB1")
Const strPath As String = "I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files"
ChDir strPath
strExtension = Dir(strPath & "*.xlsm")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
Set wsSrc = Sheets("CC")
wsSrc.Range("F24:AK24").Copy
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wsSrc.Range("F29:AK29").Copy
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Close savechanges:=False
End With
strExtension = Dir
Loop
Sheets("TAB1").Rows(1).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Thanks
Ryan

 

[mumps]

It worked properly with the 2 files you uploaded. The macro is now copying/pasting values only. If the formulas in the 2 ranges in your source sheets are returning blank cells, then no data will be copied/pasted. Are the formulas returning any data in your source file? If you step through the macro using F8, do the files open?

 

[ryansm05]

It worked properly with the 2 files you uploaded. The macro is now copying/pasting values only. If the formulas in the 2 ranges in your source sheets are returning blank cells, then no data will be copied/pasted. Are the formulas returning any data in your source file? If you step through the macro using F8, do the files open?

Hi Dave,

I've double checked and every cell within those ranges are populated. I've even created a blank sheet (macro enabled of course) and just populated those specific ranges so that the existing macro does not come into play.

However, when pressing F8, no files are opening?

 

[mumps]

If no files are opening then there could be something wrong with the folder path in the code or your source files don't have an "xlsm" extension.

 

[NdNoviceHlp]

I think you're Missing the backslash in folder path....

(strPath &"\" & strExtension)

or...

"I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files\"

FYI I spent many a puzzled hour with the vagaries of DIR. For some unknown reason, it sometimes doesn't find all of the files in a folder. Using the file system object resolved this problem permanently for me, so I never use DIR anymore. Dave

 

[mumps]

@NdNoviceHlp: Thanks for picking up on that. I had it in the macro I suggested but I didn't notice that the OP didn't put it in.

 

[ryansm05]

Thank you @NdNoviceHlp and @mumps - something so simple that I would never have been able to identify.

I've tested this, and yes the macro is pulling through the data of a single file. Thanks again. However, is it possible to achieve the following adaptations:

1) The macro runs automatically when opening the file (I need to run it manually via the developer tab at present) ,
2) The macro can pick up more than just a single file? At present, I've saved 3 loop through spreadsheets in the specified location and it is only returning the values from one of them.
3) To sort alphabetically (as mentioned before - I will ensure that the first column will have a formula driven text - but it is fine for the macro to copy the value and not the formula).

 

[mumps]

Place this macro in the code module for ThisWorkbook. Do the following: Hold down the ALT key and press the F11 key. This will open the Visual Basic Editor. In the left hand pane, double click on "ThisWorkbook". Copy/paste the macro into the empty window that opens up. Close the window to return to your sheet. Save the workbook as a macro-enabled file. Close it and re-open it. I'm not sure why it's picking up only one file. Make sure all the source files have an "xlsm" extension.

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, wsDest As Worksheet, wsSrc As Worksheet, lastRow As Long
    Set wsDest = ThisWorkbook.Sheets("TAB1")
    Const strPath As String = "I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            Set wsSrc = Sheets("C&C")
            wsSrc.Range("F24:AK24").Copy
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wsSrc.Range("F29:AK29").Copy
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    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.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[ryansm05]

Place this macro in the code module for ThisWorkbook. Do the following: Hold down the ALT key and press the F11 key. This will open the Visual Basic Editor. In the left hand pane, double click on "ThisWorkbook". Copy/paste the macro into the empty window that opens up. Close the window to return to your sheet. Save the workbook as a macro-enabled file. Close it and re-open it. I'm not sure why it's picking up only one file. Make sure all the source files have an "xlsm" extension.

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wkbSource As Workbook, wsDest As Worksheet, wsSrc As Worksheet, lastRow As Long
    Set wsDest = ThisWorkbook.Sheets("TAB1")
    Const strPath As String = "I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        [B]With wkbSource[/B]
            Set wsSrc = Sheets("C&C")
           [B] wsSrc.Range("F24:AK24").Copy[/B]
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wsSrc.Range("F29:AK29").Copy
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    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.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

So I've tried this code and the following has arisen when F8'ing:

- With wkbSource opens the first file in the specified location alphabetically

- wsSrc.Range("F24:AK24").Copy prompts the following error message (I have ensured that each cell within this range is populated by a formula and that the files are saved as macro-enabled).