Multiple ranges with different xCell.Values for a single MsgBox

[dharv3y78]

Hi MrExcel Forum,
Please Note: this question is also posted in another forum (ExcelForum: Posting here as well as I don't have an answer yet)

I am after a way that will enable a vba code to read one range then another range and if both ranges equal true for corresponding xCell.Value for the particular range then a MsgBox appears.

I want two ranges

First Range - F13:F13 if this range equals "Arthur"
Second Range - B16:B18 if this range equals "Weekday Daytime"

If both of the ranges are meet then I want a MsgBox to say "Please Use Hours Field"

I have the MsgBox showing for one range but can't work out how I might add another range in.

The VBACode I currently have is

Private Sub Worksheet_Change(ByVal Target As Range)
Sheet4.Unprotect password:=pwd
Application.ScreenUpdating = False
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("B16:B18"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Value = "Weekday Daytime" Then
                MsgBox "Please Use Hours Field", vbInformation, "Information Regarding Weekday Daytime"
                Exit Sub
            End If
        Next
    End If
    Application.ScreenUpdating = True
Sheet4.Protect password:=pwd
End Sub

 

[HongRu]

HTH

Private Sub Worksheet_Change(ByVal Target As Range)
    Sheet4.Unprotect Password:=pwd
    Application.ScreenUpdating = False
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    If Range("F13") = "Arthur" Then
        Set Rg = Application.Intersect(Target, Range("B16:B18"))
        If Not Rg Is Nothing Then
            For Each xCell In Rg
                If xCell.Value = "Weekday Daytime" Then
                    MsgBox "Please Use Hours Field", vbInformation, "Information Regarding Weekday Daytime"
                    Exit Sub
                End If
            Next
        End If
    End If
    Application.ScreenUpdating = True
    Sheet4.Protect Password:=pwd
End Sub

 

[dharv3y78]

@HongRu Thanks very much for your help this works exactly as I wanted it to.

Thanks again