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]

No lines are highlighted whatsoever... have you seen this before? Thanks.

 

[mumps]

Do any of the files open? Try stepping through the macro one line at a time by pressing the F8 key to see which line generates the error.

 

[ryansm05]

I can get this far, but when I next F8, this is when the error appears. It relates to this code:

wsDest.Sort.SortFields.Clear

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    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)
            wsSrc.Range("F29:AK29").Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .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.ScreenUpdating = True
End Sub

 

[ryansm05]

I'm now getting stuck at this bit of code ...

Sheets("TAB1").Sort.SortFields.Clear

Apologies that this isn't so straight forward and your help is very much appreciated.

Thanks
Ryan

 

[mumps]

I think that it would be easier to help and test possible solutions if I could work with your actual files which include any macros you are currently using. Perhaps you could upload a copy of your Summary file and one or two of your source files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[ryansm05]

I think that it would be easier to help and test possible solutions if I could work with your actual files which include any macros you are currently using. Perhaps you could upload a copy of your Summary file and one or two of your source files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

Hi Mumps,

I've shared two of the 'loop through' files and the links are below. However, the summary sheet where I need this macro created is currently a blank canvas (I was reluctant to develop this until I knew the macro was possible). Therefore, it is probably more logical for you to open a blank excel sheet also and use this as the 'summary'.

https://www.dropbox.com/s/tfrne6oai1lmcsn/20056.xlsm?dl=0
https://www.dropbox.com/s/ducdslfjsrocihz/20014.xlsm?dl=0

If you have any issues with the links please let me know and I'll come back to you.

Thanks
Ryan

 

[ryansm05]

Having re-read your message, I realise you wanted me to include any macro code that these loop-through files may contain.

However, I removed all tabs and code due to confidentiality- but you can see the code below (it ultimately fetches data: open / copy / paste / close - from a third file that I have not yet mentioned). I assume this would not affect what you're trying to do here?

Sub MonkeyNuts()


Dim wkb As Workbook: Set wkb = Workbooks.Open("X:\Shared\London\Accounts\2018\Financial Reporting\BRD\NewRev\Data.xlsx", True, True)
Dim LR As Long

With wkb
'Change the sheetname "Time" to name of second sheet. Or use Sheets(2), assuming the index number of the sheet relates to the second sheet shown in your spreadsheet
LR = .Sheets("Time").Cells(.Sheets("Time").Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Sheets("Time").Range("B1:Y30000").Value = .Sheets("Time").Range("A1:X30000").Value

LR = .Sheets("Jobs").Cells(.Sheets("Jobs").Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Sheets("Jobs").Range("A1:Z2000").Value = .Sheets("Jobs").Range("A1:Z2000").Value

LR = .Sheets("Billing").Cells(.Sheets("Billing").Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Sheets("Billing").Range("A1:O30000").Value = .Sheets("Billing").Range("A1:O30000").Value

LR = .Sheets("Costs").Cells(.Sheets("Costs").Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Sheets("Costs").Range("A1:N30000").Value = .Sheets("Costs").Range("A1:N30000").Value

.Close False
End With

Sheets("Time").Select




Set wkb = Nothing
End Sub

 

[mumps]

The 2 ranges that are being copied from the source sheets contain formulas. Do you want to copy the formulas as well as the values or just the values?

 

[ryansm05]

The 2 ranges that are being copied from the source sheets contain formulas. Do you want to copy the formulas as well as the values or just the values?

Just the values will be awesome..