Clear cell range on multiple sheets if cell on one sheet is modified.

[bjg1016]

The script below works perfect, except I need it to clear contents on worksheets labeled "Monday, Tuesday, Wednesday, Thursday, Friday" when cell (U2) on "Monday" is changed. HELP!!!


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("u2")) Is Nothing Then Exit Sub
[H8:O27,H30:O41,U30:U41].ClearContents
End Sub

[Tinbendr]

Welcome to the board!

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Worksheets("Monday").Range("u2")) Is Nothing Then
    Dim WSNames as Variant
    Dim A as Long
    WSNames = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
    For A = 0 To UBound(WSNames)
        Worksheets(WSNames(A)).Range("H8:O27", "H30:O41", "U30:U41").ClearContents
    Next
End Sub

[bjg1016]

David,

Thanks for your response, however I am now getting a compile error:
"Block If without End If"

I know this is basic debugging but I am super new to VBA and need this spoon fed to me. Sorry and Thanks.

[Tinbendr]

Oops! Copy/Paste error.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Worksheets("Monday").Range("u2")) Is Nothing Then
    Dim WSNames as Variant
    Dim A as Long
    WSNames = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
    For A = 0 To UBound(WSNames)
        Worksheets(WSNames(A)).Range("H8:O27", "H30:O41", "U30:U41").ClearContents
    Next
End If
End Sub

[bjg1016]

Now I'm getting a "Run-time error '450': Wrong number of arguments or invalid property assignment" I have attached a copy of the workbook. Please see attached.

Thanks.
blank template (1 day) v4.2.xls

[bjg1016]

oops wrong file. I forgot to save changes. try this one
blank template (1 day) v4.2.xls

[wallyeye]

It doesn't like the quotes mid-stream on the Range argument:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Range("u2")) Is Nothing Then
        Dim WSNames As Variant
        Dim A As Long
    
        Application.EnableEvents = False
        WSNames = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
        For A = LBound(WSNames) To UBound(WSNames)
            Worksheets(WSNames(A)).Range("H8:O27,H30:O41,U30:U41").ClearContents
        Next
        Application.EnableEvents = False
    End If

End Sub

[bjg1016]

It doesn't like the quotes mid-stream on the Range argument:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Target, Range("u2")) Is Nothing Then
        Dim WSNames As Variant
        Dim A As Long
    
        Application.EnableEvents = False
        WSNames = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
        For A = LBound(WSNames) To UBound(WSNames)
            Worksheets(WSNames(A)).Range("H8:O27,H30:O41,U30:U41").ClearContents
        Next
        Application.EnableEvents = False
    End If

End Sub

Thanks a million It works like a charm.

[royUK]

Try this

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("u2")) Is Nothing Then Exit Sub
    Sheets(Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")).Select
    Me.Range("H8:O27,H30:O41,U30:U41").Select
    Selection.ClearContents
Me.Range("A1").Select
End Sub

[bjg1016]

Is there a way to ungroup them when it is done clearing the contents, because if I input any data into any sheet in the group it copies the data to the other sheets.

[bjg1016]

Thank you everyone!!!

[bjg1016]

Follow up,

I submitted this unprotected, but when I password protected the sheet it will no longer work. I'm getting "Run-time error '1004': The cell or chart that you are trying to change is protected and therefore read-only. To modify a protected cell or chart, first remove protection using the Unprotect Sheet command (Review tab, Changes group). You may be prompted for a password." Can you please amend the code below to compensate for this?

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("u2")) Is Nothing Then
Dim WSNames As Variant
Dim A As Long

Application.EnableEvents = False
WSNames = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Vacation", "Holiday", "Funeral", "Jury")
For A = LBound(WSNames) To UBound(WSNames)
Worksheets(WSNames(A)).Range("H8:O27,H30:O41,U30:U41").ClearContents
Next
Application.EnableEvents = False
End If

End Sub

[wallyeye]

I have a sheet protection function I use, it allows me to store the protection password in one location, rather than everywhere I need to protect/unprotect the sheet:

Option Explicit

Public Sub SheetProtect(Optional wksCurr As Variant)
On Error GoTo Proc_Error
'
'  Apply worksheet protection.  If a sheet is passed, protect only that sheet,
'    else protect all sheets
'
    Dim strPW As String

    strPW = "mypass"
    If IsMissing(wksCurr) Then
        For Each wksCurr In ThisWorkbook.Worksheets
            wksCurr.Protect (strPW)
        Next wksCurr
        Set wksCurr = Nothing
    Else
        If VarType(wksCurr) = vbObject Then
            If TypeOf wksCurr Is Worksheet Then
                wksCurr.Protect (strPW)
            End If
        End If
    End If

Proc_Exit:

    Exit Sub

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

    Exit Sub

End Sub

Public Function SheetUnprotect(Optional wksCurr As Variant) As Boolean
On Error GoTo Proc_Error
'
'  Apply worksheet protection.  If a sheet is passed, unprotect only that sheet,
'    else unprotect all sheets
'
    Dim strPW As String

    strPW = "mypass"
    If IsMissing(wksCurr) Then
        For Each wksCurr In ThisWorkbook.Worksheets
            wksCurr.Unprotect (strPW)
        Next wksCurr
        Set wksCurr = Nothing
    Else
        If VarType(wksCurr) = vbObject Then
            If TypeOf wksCurr Is Worksheet Then
                SheetUnprotect = wksCurr.ProtectContents
                wksCurr.Unprotect (strPW)
            End If
        End If
    End If

Proc_Exit:

    Exit Function

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

    Exit Function

End Function

Put it in a new module, change the password to match yours, then change the routine:

        For A = LBound(WSNames) To UBound(WSNames)
            SheetUnprotect(worksheets(wsnames(A)))
            Worksheets(WSNames(A)).Range("H8:O27,H30:O41,U30:U41").ClearContents
            SheetProtect(worksheets(wsnames(A)))
        Next

You can add parameters to the .Protect statement, check the help files. I had some spreadsheets I support that had 40-50 locations that protected/unprotected the worksheets, this function cut down on maintenance quite a bit. You can also pass worksheets identified with their codenames to it.

[royUK]

I added the ungroup line, it should be

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("u2")) Is Nothing Then Exit Sub
    Sheets(Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")).Select
    Me.Range("H8:O27,H30:O41,U30:U41").Select
    Selection.ClearContents
    Me.Select
End Sub

To get round the the protection issue you can use Protect with UserInterface, that allows macros to work on protected sheets.

[bjg1016]

Hello everyone,

I'm back with a follow up modification request.

I would like to replace the worksheet names "Monday, etc" and set this script to clear the cells throughout the entire workbook. Can anyone help me?

Thanks a million in advance.

[wallyeye]

I don't know how to select all the worksheets in a dynamic array like the previous example, this loops through each worksheet:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wksCurr                 As Worksheet

    Dim intCalc                 As Integer

    If Intersect(Target, Range("u2")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    intCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    For Each wksCurr In ThisWorkbook.Worksheets
        wksCurr.Range("H8:O27,H30:O41,U30:U41").ClearContents
    Next wksCurr
    Application.EnableEvents = True
    Application.Calculation = intCalc

End Sub