Apply macro to all workbooks in folder

[chrisellis250]

Hi everyone,

I have the following codes:

Option Explicit

Sub Procedure1()
Dim N As Long
Dim URNRow As Long

For N = 2 To Sheets("Sheet1").Cells(Rows.Count, 13).End(xlUp).Row
    
    If WorksheetFunction.CountIf(Sheets("Sheet2").Range(Sheets("Sheet2").Columns(5), Sheets("Sheet2").Columns(10)), Sheets("Sheet1").Cells(N, 13)) > 0 Then
        URNRow = Sheets("Sheet2").Range(Sheets("Sheet2").Columns(5), Sheets("Sheet2").Columns(10)).Find(Sheets("Sheet1").Cells(N, 13), , xlValues, xlWhole).Row
        If Sheets("Sheet2").Cells(URNRow, 3).MergeArea(1) = Sheets("Sheet1").Cells(N, 31) Then
            Sheets("Sheet1").Range(Sheets("Sheet1").Cells(N, 13), Sheets("Sheet1").Cells(N, 20)).Interior.Color = Sheets("Sheet2").Cells(URNRow, 2).MergeArea(1).Interior.Color
        End If
    End If
Next N
End Sub

Sub Procedure2()
Dim N As Long
Dim URNRow As Long

For N = 2 To Sheets("Sheet1").Cells(Rows.Count, 13).End(xlUp).Row
    
    If WorksheetFunction.CountIf(Sheets("Sheet2").Range(Sheets("Sheet2").Columns(5), Sheets("Sheet2").Columns(10)), Sheets("Sheet1").Cells(N, 21)) > 0 Then
        URNRow = Sheets("Sheet2").Range(Sheets("Sheet2").Columns(5), Sheets("Sheet2").Columns(10)).Find(Sheets("Sheet1").Cells(N, 21), , xlValues, xlWhole).Row
        If Sheets("Sheet2").Cells(URNRow, 3).MergeArea(1) = Sheets("Sheet1").Cells(N, 31) Then
            Sheets("Sheet1").Range(Sheets("Sheet1").Cells(N, 21), Sheets("Sheet1").Cells(N, 28)).Interior.Color = Sheets("Sheet2").Cells(URNRow, 2).MergeArea(1).Interior.Color
        End If
    End If
Next N

End Sub

I run them both via:

Sub Colour()
Procedure1
Procedure2
End Sub

However, i was wondering if there was a way I could apply this to all of the workbooks in a particular folder? Simply to save having to do this to a large number of spreadsheets.

There are 61 spreadsheets in a folder called "GR12 Schedules" and each file is called "GR12 Schedule" and then a number i.e Schedule 1, Schedule 2 etc up to 61

Many thanks,

Chris

[Ochimus]

I adapted this to open each file in a Folder, but if any of the workbooks are password protected, don't forget to use a "wildcard" when defining the file type to open.

https://www.thespreadsheetguru.com/t...a-given-folder

Hope it helps

Ochimus

[AlphaFrog]

Change the folder path to suit.

Sub Colour_All()
    Dim sPath As String, sFile As String, counter As Long
    
    sPath = "C:\GR12 Schedules\"
    
    sFile = Dir(sPath & "GR12 Schedules*.*")
    
    Application.ScreenUpdating = False
    Do While sFile <> ""
        With Workbooks.Open(sPath & sFile)
            Procedure1
            Procedure2
            .Close SaveChanges:=True
        End With
        counter = counter + 1
        sFile = Dir
    Loop
    Application.ScreenUpdating = True
    
    MsgBox counter & " files coloured.", , "Colour Files Complete"
    
End Sub

[chrisellis250]

Hi AlphaFrog,

Many thanks for your response, much appreciated

I have amended your code to fit with the correct folder locations etc and I am getting "0 files coloured" messaged at the end.

[AlphaFrog]

Can you show your amended code?

[chrisellis250]

Sub Colour_All()
    Dim sPath As String, sFile As String, counter As Long
    
    sPath = "J:\XXXXXX\XXXXXXXX\CPA\Part 2\Schedules"
    
    sFile = Dir(sPath & "GR12 Schedule*.*")
    
    Application.ScreenUpdating = False
    Do While sFile <> ""
        With Workbooks.Open(sPath & sFile)
            Procedure1
            Procedure2
            .Close SaveChanges:=True
        End With
        counter = counter + 1
        sFile = Dir
    Loop
    Application.ScreenUpdating = True
    
    MsgBox counter & " files coloured.", , "Colour Files Complete"
    
End Sub

[AlphaFrog]

Missing the trailing \

sPath = "J:\XXXXXX\XXXXXXXX\CPA\Part 2\Schedules\"

Isn't your folder called "GR12 Schedules" ?