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

 

[NdNoviceHlp]

Hi Ryan. Where exactly is the data located (sheet name and cell location) and where do U want to put the info (sheet name and cell location)? VBA will be required to complete your request. Dave

 

[ryansm05]

Hi Dave,

Thanks for replying so quickly. Just to clarify, I will be needing to pull data from multiple spreadsheets. So when I'm pulling the data into my summary sheet, can we start at F5:AK5 and then work down in every next available row. This summary file that I'm working from will be located: I:\Accounts\2018\Management Accounts\

However, the spreadsheets I'm wanting to extract the data from will come from multiple cells, but for now can I just pull in the following data:
- PULL DATA: F24:AK24
- PULL DATA: F39:AK39

These sheets will be saved: I:\Accounts\2018\Financial Reporting\BRD\NewRe and the tab names will be C&C


Thanks again,
Ryan

 

[NdNoviceHlp]

Hi Ryan. Not real clear where your wb files are... folder... I:\Accounts\2018\Management Accounts\ ?? Are they .xlsm files? What is the sheet name where the data is... "PULL DATA"??? Where do U want to put the data in C&C … in the same location as extraction? Anyways, the following code loops through all files in the folder I:\Accounts\2018\Management Accounts\ and checks .xlsm files only. It transfers data (F24:AK24 and F39:AK39) from the sheet named "PULL DATA" to the C&C sheet of the open wb (starting in "F" 24 and "F" 39). I'm guessing this isn't exactly what you want. Dave

Option Explicit
Sub test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, 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\Management Accounts\")
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 = "Pulldata" Then
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F24:AK24").Copy _
    Destination:=ThisWorkbook.Sheets("C&C").Cells(24, Cnt + 5)
Application.CutCopyMode = False
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F39:AK39").Copy _
    Destination:=ThisWorkbook.Sheets("C&C").Cells(39, Cnt + 5)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
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

 

[ryansm05]

Hi Dave,

I'm going to try this shortly, however, a few points I provably didn't make clear.

1) The file I'm working on and want to build the macro in will be saved: I:\Accounts\2018\Management Accounts and the file name is Summary Sheet. The tab name is also Summary sheet.

2) The files I'm wanting to loop through will have a different filenames (all starting with a 5 digit project code) and will be saved here I:\Accounts\2018\Financial Reporting\BRD\NewRev

3) The tab name of each of the loop through files (saved with a 5 digit project code) will be C&C

4) These loop through files (saved with a 5 digit project code) are now saved as xlsm. so will be compatible with your code

5) From each of these loop through files (saved with a 5 digit project code), I need to extract the data from F24:AK24 and F29:AK29

6)The data (F24:AK24 and F29:AK29) from each of the loop through files (saved with a 5 digit project code) needs to be extracted to the Summary Sheet workbook in tab Summary Sheet as described in 1)

7) Once extracted to the summary sheet workbook/tab - I then need to sort all returned data alphabetically by column F


Hopefully this gives you a clearer indication of what I'm looking for - and apologies for any confusion.

Thanks
Ryan

 

[NdNoviceHlp]

Hi Ryan. You still didn't say where you want the data put in Summary Sheet of summary sheet? This code puts it in the same cell location that it came from. The code does not sort anything yet. This code goes in your Summary Sheet wb (ie the wb that you are placing the data in). I'm also having trouble following yours tab definitions... there are workbooks and worksheets please refer to them for clarity. Dave

Option Explicit
Sub test()
Dim Lastrow As Double, sht As Worksheet, Cnt As Double, 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\")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each FileNm In FlDr.Files
If FileNm.Name Like "*.xlsm" Then
If FileNm.Name = "Summary Sheet" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "C&C" Then
Cnt = Cnt + 1
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F24:AK24").Copy _
    Destination:=ThisWorkbook.Sheets("Summary Sheet").Cells(24, Cnt + 5)
Application.CutCopyMode = False
Workbooks(FileNm.Name).Sheets(sht.Name).Range("F39:AK39").Copy _
    Destination:=ThisWorkbook.Sheets("Summary Sheet").Cells(39, Cnt + 5)
Application.CutCopyMode = False
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
End If
Next FileNm
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

 

[ryansm05]

Hi Dave - thanks for coming back to all these messages.

My bad for the poor references. I'll try again and will update the tab names to prevent confusion:



1) The file I'm working on and want to build the macro in will be saved: I:\Accounts\2018\Management Accounts and the file name is Summary Sheet. The tab name is TAB1.

2) The files I'm wanting to loop through will have a different filenames (all starting with a 5 digit project code) and will be saved here I:\Accounts\2018\Financial Reporting\BRD\NewRev

3) The tab name of each of the loop through files (saved with a 5 digit project code) will be C&C

4) These loop through files (saved with a 5 digit project code) are now saved as xlsm. so will be compatible with your code

5) From each of these loop through files (saved with a 5 digit project code), I need to extract the data from F24:AK24 and F29:AK29

6)The data (F24:AK24 and F29:AK29) from each of the loop through files (saved with a 5 digit project code) needs to be extracted to the Summary Sheet file in TAB1 as described in 1). At present this can be extracted to cell A1 until I develop it a little further. I'm assuming it'll just be a case of updating the code to the desired range?

7) Once extracted to the summary sheet workbook/tab - I then need to sort all returned data alphabetically by column F

 

[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
    wsDest.Rows(1).EntireRow.Delete
    lastRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    wsDest.Sort.SortFields.Clear
    wsDest.Sort.SortFields.Add Key:=Range("A1:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wsDest.Sort
        .SetRange Range("A1:A" & lastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub

The macro assumes that your source files are the only files in the "NewRev" folder. BY the way, the source files don't have to have an "xlsm" extension. They can have an "xlsx" extension if it suits you. Just change the extension in the code.

 

[ryansm05]

Afternoon Mumps!!! Thanks for building on what Dave was helping me with.

I have tried your code (I updated a file location and range of data) but I'm getting the below error. It may be that I've done something wrong when entering the code - but hopefully you will be able to tell from the error code 'Run-time error 91'

Thanks
Ryan

 

[mumps]

Which line of code was highlighted?