Change cell or range in all workbooks in a folder

Important message to visitors of this page

Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.

Luckily, Ron was kind enough to allow me to publish all of his Excel content here.

Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.

Kind regards

Jan Karel Pieterse

Code Examples

Copy the code in a Standard module of your workbook, if you just started with VBA see this page.
Where do I paste the code that I find on the internet

There are a few basic examples on this page:

1) Change a cell value in one or all worksheets in every workbook in a folder
2) Change the header or footer in all worksheets in every workbook in a folder
3) Copy a range to one or all worksheets in every workbook in a folder
4) Copy a worksheet to all workbooks in a folder

Information and Tips

The examples below are only working for one folder (no option for subfolders).

Important: The workbook with the code must be outside the merge folder and the destination sheet(s) in every workbook must be unprotected. But you can add unprotect and protect code to the macro if your sheets are protected

Tip 1: Useful Workbooks.Open arguments

Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), _
Password:="ron", WriteResPassword:="ron", UpdateLinks:=0)

If your workbooks are protected you can use this in the Workbooks.Open arguments
Password:="ron” and WriteResPassword:="ron"

If you have links in your workbook this (UpdateLinks:=0)
will avoid the message do you want to update the links or not "0 Doesn't update any references"
See the VBA help for more information about the Workbooks.Open arguments

Tip 2: Change only cells in files with a name that start with for example week, you can use this then
FilesInPath = Dir(MyPath & "week*.xl*")

Change cell or range in one or all worksheets in each file

There are a few things you must change before you can run the code

Fill in the path to the folder with files
MyPath = "C:\Users\Ron\test"

In the example below I change a cell on the first worksheet(index 1) of each workbook in the folder "C:\Users\Ron\test" with this line With mybook.Worksheets(1)
Change the sheet index or use a sheet name: mybook.Worksheets("YoursheetName")

Change this line to your cell and value
.Range("A1").Value = "My New Header"
Note: you can repeat this line in the macro for other cells

Tip: You can replace the red code block with the other examples below this macro

Sub Example()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then


                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    If .ProtectContents = False Then
                        .Range("A1").Value = "My New Header"
                    Else
                        ErrorYes = True
                    End If
                End With


                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If

        Next Fnum
    End If

    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If

    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Other examples

You can replace this code block from the macro above with the examples below

                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    If .ProtectContents = False Then
                        .Range("A1").Value = "My New Header"
                    Else
                        ErrorYes = True
                    End If
                End With

With one of the examples below:

Change a cell value or change a header or footer in all worksheets in each workbook

Tip: not loop through all worksheets in mybook

You can replace
For Each sh In mybook.Worksheets

With this if you want to loop through the sheets in the array
For Each sh In Sheets(Array("Sheet1", "Sheet3"))

If you want to copy only to sheets with a name that start with week
For Each sh In mybook.Worksheets
If LCase(Left(sh.Name, 4)) = "week" Then

Do not forget to add a End IF if you want to test the sheet name

'Change cell value(s) in all worksheets in mybook
    On Error Resume Next
    For Each sh In mybook.Worksheets
        If sh.ProtectContents = False Then
            With sh
                .Range("A1").Value = "My New Header"
                ' Or change a header or footer in every worksheet
                ' Example to add the Workbook's Full Path in the footer
                '.PageSetup.LeftFooter = mybook.FullName
            End With
        Else
            ErrorYes = True
        End If
    Next sh

Copy a range to one worksheet in mybook

This is the worksheet where you paste the range
Set sh = mybook.Worksheets(1)

This is the range that you copy
ThisWorkbook.Worksheets(1).Range("A1:C1")

We paste in A1 of sh
sh.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value

    'Copy a range to a worksheet in mybook
    On Error Resume Next
    Set sh = mybook.Worksheets(1)
    With sh
        If .ProtectContents = False Then
            With ThisWorkbook.Worksheets(1).Range("A1:C1")
                sh.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
            End With
        Else
            ErrorYes = True
        End If
    End With

Copy a range to all worksheets in mybook

'Copy a range to all worksheets in mybook
    On Error Resume Next
    For Each sh In mybook.Worksheets
        If sh.ProtectContents = False Then
            With sh
                With ThisWorkbook.Worksheets(1).Range("A1:C1")
                    sh.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
                End With
            End With
        Else
            ErrorYes = True
        End If
    Next sh

Copy a worksheet to all workbooks in a folder

There are a few things you must change before you can run the code

Fill in the path to the folder with files
MyPath = "C:\Users\Ron\test"

Which sheet do you want to copy, change this line
Set MySh = ThisWorkbook.Sheets("Sheet1")

And give the sheet you paste in every workbook a name
ActiveSheet.Name = "MyNewSheet"

Sub Example_3()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim MySh As Worksheet

    On Error Resume Next
    ' Worksheet that you want to paste in each workbook
    Set MySh = ThisWorkbook.Sheets("Sheet1")
    If Err.Number > 0 Then
        Err.Clear
        MsgBox "The sheet that you want to copy/paste not exist"
        Exit Sub
    End If
    On Error GoTo 0

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                'Copy/paste the sheet
                MySh.Copy after:=mybook.Sheets(mybook.Sheets.Count)

                'Give the sheet a name
                On Error Resume Next
                ActiveSheet.Name = "MyNewSheet"
                If Err.Number > 0 Then
                    MsgBox "Change the name of : " & ActiveSheet.Name & " manually" & _
                         " in the workbook " & mybook.Name
                    Err.Clear
                End If
                On Error GoTo 0

                'Save and close mybook
                mybook.Close savechanges:=True

            End If
        Next Fnum
    End If

    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Ron de BruinExcel Automation