Conditional Formatting Error Message Box VBA not working as expected

[SaraWitch]

Hello peeps,

I want an error message box to show if "Completed" is in red (rather than using a data validation input message, because I don't want it to show all the time). The code I'm using, but is not working, is:

Sub ShowMessageBoxForRedCompletedOnAllSheets()
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim targetWord As String
   
    targetWord = "Completed"
   
    For Each ws In ThisWorkbook.Worksheets
        Set targetCell = ws.Columns("A")
       
        If targetCell.Font.Color = RGB(192, 0, 0) Then
            MsgBox "Please enter actual start date and/or reference number", vbOKOnly, "Missing data!"
        End If
    Next ws
End Sub

¦ MrExcel Queries.xlsm
	A	B	C	D	E	F	G
1	Status	other column	other column	Start date	other column	other column	Ref number
2	Completed						12345678
3	Completed			19/08/2024			34567
4	Open			19/08/2024			2586
5	Completed						1234
CF Error MsgBox

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2:A6	Expression	=IF($A2="Completed", OR($D2="", $G2=""))	text	NO

Any help would be appreciated

 

[kvsrinivasamurthy]

Try

Sub ShowMessageBoxForRedCompletedOnAllSheets()
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim targetWord As String
   
    targetWord = "Completed"
   
    For Each ws In ThisWorkbook.Worksheets
        For Each targetCell In ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
       
        If targetCell.Font.Color = RGB(255, 0, 0) And targetCell.Text = targetWord Then
            MsgBox "Please enter actual start date and/or reference number for row number " & targetCell.Row, vbOKOnly, "Missing data!"
        End If
        Next targetCell
    Next ws
End Sub

 

[kvsrinivasamurthy]

This code may be better as numbers can be entered.

Sub ShowMessageBoxForRedCompletedOnAllSheets()
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim targetWord As String
    Dim Ro&
    targetWord = "Completed"
   
    For Each ws In ThisWorkbook.Worksheets
        For Each targetCell In ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
       
        If targetCell.Font.Color = RGB(255, 0, 0) And targetCell.Text = targetWord Then
        Ro = targetCell.Row
            If Range("D" & Ro) = "" Then
            Range("D" & Ro).Value = InputBox("Please enter actual start date for row number " & Ro, "Missing data!")
            End If
            If Range("G" & Ro) = "" Then
            Range("G" & Ro).Value = InputBox("Please enter actual reference number for row number " & Ro, "Missing data!")
            End If

        End If
        Next targetCell
    Next ws
End Sub

 

[RoryA]

Conditional formatting doesn't affect the direct cell properties - you need to use DisplayFormat:

If targetCell.DisplayFormat.Font.Color = RGB(192, 0, 0) Then

 

[SaraWitch]

Brilliant! Thank you both, so much - combined, it works perfectly!

And is there a way for this message box to pop up automatically every time "Completed" is entered (i.e., without have to manually run the macro)? Or will I have to assign it to an action button? It would be great if it's automatic! (Or both!)

 

[RoryA]

As long as that column is not formula driven, then a Worksheet_Change event would work.

 

[SaraWitch]

Amazing! Thank you!

Just a couple of things...

a) I already have a code for multiple select (and deselect) from a DDL on that sheet. I have tried to combine the codes but it's not working, and
b) is there a way to set the date format to dd/mm/yyyy (I have a date data validation on the worksheet column, but this overrides it (and I need it in this date format to feed into something else!)).

Private Sub Worksheet_Change(ByVal Target As Range)
'Red Word Message Box
    Dim ws As Worksheet
    Dim targetCell As Range
    Dim targetWord As String
    Dim Ro As Long
'Multiple Selection from DDL
    Dim rngDropdown As Range
    Dim oldValue As String
    Dim newValue As String
    Dim DelimiterType As String
    Dim DelimiterCount As Integer
    Dim TargetType As Integer
    Dim i As Integer
    Dim arr() As String
    
'Red Word Message Box
    targetWord = "Completed"
'Multiple Selection from DDL
    DelimiterType = vbCrLf

'Red Word Message Box
    For Each ws In ThisWorkbook.Worksheets
        For Each targetCell In ws.Range("B1", ws.Range("B" & Rows.Count).End(xlUp))
            If targetCell.DisplayFormat.Font.Color = RGB(192, 0, 0) Then
                Ro = targetCell.Row
                If Range("DD" & Ro) = "" Then
                    Range("DD" & Ro).Value = InputBox("Please enter actual tenancy start date - format dd/mm/yyyy - for row number " & Ro, "Missing data!")
                End If
                If Range("DN" & Ro) = "" Then
                    Range("DN" & Ro).Value = InputBox("Please enter tenancy reference number for row number " & Ro, "Missing data!")
                End If
            End If
        Next targetCell
    Next ws

'Multiple Selection from DDL
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    
    Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitError
    
    If Target.Column <> 3 And Target.Column <> 18 And Target.Column <> 20 And Target.Column <> 47 And Target.Column <> 49 And Target.Column <> 67 And Target.Column <> 71 And Target.Column <> 116 Then GoTo exitError 'currently C.C, C.R, C.T, C.AU, C.AW, C.BO, C.BS, C.DL
    
    TargetType = 0
    TargetType = Target.Validation.Type
    If TargetType = 3 Then ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Target.Value
        Application.Undo
        oldValue = Target.Value
        Target.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Target.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                    arr = Split(oldValue, DelimiterType)
                    If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                        Target.Value = oldValue & DelimiterType & newValue
                    Else
                        Target.Value = ""
                        For i = 0 To UBound(arr)
                            If arr(i) <> newValue Then
                                Target.Value = Target.Value & arr(i) & DelimiterType
                            End If
                        Next i
                        Target.Value = Left(Target.Value, Len(Target.Value) - Len(DelimiterType))
                    End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Target.Value = oldValue
                Else
                    Target.Value = oldValue & DelimiterType & newValue
                End If
                Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                Target.Value = Replace(Target.Value, DelimiterType & Replace(DelimiterType, " ", ""),
    End If
exitError:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub