Limit macro to certain cell range

[MeaclH]

G'day,
I have a macro that runs on my sheet perfectly fine, however, I have decided I would like to prevent it being run on any cell on the sheet. Users are making errors and running the macro on cells that they shouldn't.

Is there a modification I can make to the code to limit he execution to G5:T9
And if a user does run it on any other cell they are prompted with a custom error message?

Sub MarkShiftCovered()
     Dim sCmt As String
    Dim rCell As Range
    
    sCmt = InputBox( _
      Prompt:="Have you covered this shift in it's entirety?" & vbCrLf & _
      "Please add details of how the shift has been covered. ie. OFF roster, extensions.", _
      Title:="Comment to Add")
    If sCmt = "" Then
        MsgBox "Not actioned. Has the shift been covered?"
    If StrPtr(sCmt) = 0 Then Exit Sub 'user cancelled inputbox
            Else
        For Each rCell In Selection
            With rCell
                ActiveSheet.Unprotect
                .ClearComments
                .AddComment
                .Comment.Text Text:=sCmt
            End With
        Next
    End If
    Set rCell = Nothing
Selection.Font.Color = RGB(0, 0, 0)
Selection.Interior.ColorIndex = xlNone
Selection.Font.Underline = False
Selection.Font.Bold = False
Selection.Font.Strikethrough = True
ActiveSheet.Protect DrawingObjects:=False
End Sub

Cheers,
Hayden

 

[Joe4]

This update should only run your code on the selected cells found within G5:T9.

Sub MarkShiftCovered()
    Dim sCmt As String
    Dim rng As Range
    Dim rCell As Range
    
    sCmt = InputBox( _
      Prompt:="Have you covered this shift in it's entirety?" & vbCrLf & _
      "Please add details of how the shift has been covered. ie. OFF roster, extensions.", _
      Title:="Comment to Add")
    If sCmt = "" Then
        MsgBox "Not actioned. Has the shift been covered?"
    If StrPtr(sCmt) = 0 Then Exit Sub 'user cancelled inputbox
            Else
            
'       Limit to specific range
        Set rng = Intersect(Selection, Range("G5:T9"))
        
'       Exit if no cells in specified range
        If rng Is Nothing Then
            MsgBox "You range selection does not contain any cells in G5:T9", vbOKOnly, "ERROR!"
            Exit Sub
        End If
            
        For Each rCell In rng
            With rCell
                ActiveSheet.Unprotect
                .ClearComments
                .AddComment
                .Comment.Text Text:=sCmt
            End With
        Next
    End If
    Set rCell = Nothing
    
    rng.Font.Color = RGB(0, 0, 0)
    rng.Interior.ColorIndex = xlNone
    rng.Font.Underline = False
    rng.Font.Bold = False
    rng.Font.Strikethrough = True
    ActiveSheet.Protect DrawingObjects:=False

End Sub

 

[MeaclH]

This update should only run your code on the selected cells found within G5:T9.

Sub MarkShiftCovered()
    Dim sCmt As String
    Dim rng As Range
    Dim rCell As Range
   
    sCmt = InputBox( _
      Prompt:="Have you covered this shift in it's entirety?" & vbCrLf & _
      "Please add details of how the shift has been covered. ie. OFF roster, extensions.", _
      Title:="Comment to Add")
    If sCmt = "" Then
        MsgBox "Not actioned. Has the shift been covered?"
    If StrPtr(sCmt) = 0 Then Exit Sub 'user cancelled inputbox
            Else
           
'       Limit to specific range
        Set rng = Intersect(Selection, Range("G5:T9"))
       
'       Exit if no cells in specified range
        If rng Is Nothing Then
            MsgBox "You range selection does not contain any cells in G5:T9", vbOKOnly, "ERROR!"
            Exit Sub
        End If
           
        For Each rCell In rng
            With rCell
                ActiveSheet.Unprotect
                .ClearComments
                .AddComment
                .Comment.Text Text:=sCmt
            End With
        Next
    End If
    Set rCell = Nothing
   
    rng.Font.Color = RGB(0, 0, 0)
    rng.Interior.ColorIndex = xlNone
    rng.Font.Underline = False
    rng.Font.Bold = False
    rng.Font.Strikethrough = True
    ActiveSheet.Protect DrawingObjects:=False

End Sub

works perfectly. Thanks legend!!!

 

[Joe4]

You are welcome.
Glad I was able to help!