VBA Excel to popup a message if a cell in a range is colored red

[David Montoya]

I need some assistance. The following code is not working for me, as it does not create the popup.

Sub FindColor()
    
Range("D4:P1004").Select
If ActiveCell.Interior.Color = 255 Then
    MsgBox ("Leave a Comment")
End If
End Sub

 

[Scott T]

How is the cell colored?

If it is formatted by conditional formatting you need to use

If ActiveCell.DisplayFormat.Interior.Color = 255 Then    MsgBox "Leave a Comment"
End If

DisplayFormat
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-displayformat-property-excel

 

[David Montoya]

Yes, it is formatted by conditional formatting. I have modified the code per your instructions, it runs, but it only selects the range without doing the popup:

Sub [COLOR=#333333]FindColor[/COLOR]()
    
Range("D4:P1004").Select
If ActiveCell.DisplayFormat.Interior.Color = 255 Then
MsgBox ("Leave a Comment")
End If


End Sub

 

[mikerickson]

I think this might do what you want

Sub test()
    Dim oneCell As Range, newNote As String

    For Each oneCell In Range("D4:P1004")
        With oneCell
            If oneCell.DisplayFormat.Interior.Color = vbRed Then
                newNote = Application.InputBox("Enter a comment in " & .Address, Default:=.NoteText)
                If newNote = "False" Then
                    Exit For
                Else
                    .NoteText newNote
                End If
            End If
        End With
    Next oneCell
End Sub

 

[David Montoya]

Mike, excellent! it works.

 

[Rick Rothstein]

Another way for you to handle this is to simply alert the user that one or more cells do not have the required note in them and let the user find the red cell on their own. Doing it this way allows you to avoid looping through the cells one cell at a time in code looking for the red cell... the cell is red so the user should be able to find it quite easily. Here is the code to do it this way...

[table="width: 500"]
[tr]
	[td]Sub RedCellRequiresComment()
  With Range("D3:P1004")
    If IsNull(.DisplayFormat.Interior.ColorIndex) Then
      MsgBox "One (or more) of the cells in Range D3:P1004 is colored red indicating they require you to put a note in it (them)."
      Exit Sub
    End If
  End With
End Sub[/td]
[/tr]
[/table]

 

[David Montoya]

Rick, thanks a lot for your input. Actually, it is my intention to develop the mentioned macro as part of a another; I will prefer to have this portion run, and if found the cell in red, which I have conditionally formatted in case of a missing information, to stop the rest of the execution, and back to the worksheet called "Master Query". The following is how I have developed so far; it runs fine but the complete macro runs, and at the end it displays the popup message. It will be best if the red cell is identified, making sure to complete the necessary information before run it again.Thanks again for you assiatance.

Sub BrokerFilter()

Application.DisplayAlerts = False
Application.ScreenUpdating = False


Sheets("Std").Copy
With ActiveSheet.UsedRange
    .Value = .Value
End With
    
Sheets("Std").Select
Range("$A$3:$P$1004").AutoFilter Field:=16, Criteria1:="=True" _
        , Operator:=xlOr, Criteria2:="="
    Set LastCell = Cells(Cells.Find(what:="*", SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
      Cells.Find(what:="*", SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
  Set FirstCell = Cells(Cells.Find(what:="*", After:=LastCell, SearchOrder:=xlRows, _
      SearchDirection:=xlNext, LookIn:=xlValues).Row, _
      Cells.Find(what:="*", After:=LastCell, SearchOrder:=xlByColumns, _
      SearchDirection:=xlNext, LookIn:=xlValues).Column)
    Application.DisplayAlerts = False
    ActiveSheet.UsedRange.Offset(3, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
    Application.DisplayAlerts = True
    ActiveSheet.Range("$A$3:$P$1004").AutoFilter Field:=16
 
    Columns("P:P").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    
    Range("A4").Select
 
'Delete blank colums


    Dim MyRange As Range
    Dim iCounter As Long
'Step 2:  Define the target Range.
    Set MyRange = ActiveSheet.UsedRange
    
'Step 3:  Start reverse looping through the range.
    For iCounter = MyRange.Columns.Count To 1 Step -1
    
'Step 4: If entire column is empty then delete it.
      If Application.CountA(Intersect(MyRange.Offset(3), Columns(iCounter))) = 0 Then
       Columns(iCounter).Delete
       End If
'Step 5: Increment the counter down
    Next iCounter


'Copy to Clipboard


    If Not Range("E4:F1004").Find(what:="RQD", LookIn:=xlValues, lookAt:=xlWhole, MatchCase:=True) Is Nothing Then
        MsgBox ("Review MSDS to determine if Positive, or Negative Certificate is required")
    End If
    
    If Not Range("E4:F1004").Find(what:="P", LookIn:=xlValues, lookAt:=xlWhole, MatchCase:=True) Is Nothing Then
        MsgBox ("Complete TSCA Certificate")
    End If
    
    If Not Range("E4:F1004").Find(what:="N", LookIn:=xlValues, lookAt:=xlWhole, MatchCase:=True) Is Nothing Then
        MsgBox ("Complete TSCA Certificate")
    End If
    
    If Not Range("E4:F1004").Find(what:="RH1810212", LookIn:=xlValues, lookAt:=xlWhole, MatchCase:=True) Is Nothing Then
        MsgBox ("Complete FDA-2877 Form")
    End If
    
    If Not Range("E4:O1004").Find(what:="M2 Rqd", LookIn:=xlValues, lookAt:=xlWhole, MatchCase:=True) Is Nothing Then
        MsgBox ("Review measurements to determine square meters")
    End If
    
    Dim oneCell As Range
    For Each oneCell In Range("D4:P1004")
        With oneCell
            If oneCell.DisplayFormat.Interior.Color = vbRed Then
                MsgBox ("Complete missing manufacturer's information")
            End If
        End With
    Next oneCell
    
    Worksheets("Std").UsedRange
    Worksheets("Std").UsedRange.Select
    Selection.Copy


Application.DisplayAlerts = False
Application.ScreenUpdating = False


ActiveWorkbook.Close


Windows("Trade Compliance Database Tool.xlsb").Activate
    Sheets("Master Query").Select
    Range("A4").Select


Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

 

[David Montoya]

Rick, I have adjusted the macro to include your portion at the beginning followed by what I have already in place, and it works like a charm. Thanks a lot for your assistance!

Sub BrokerFilter()

Application.DisplayAlerts = False
Application.ScreenUpdating = False


    With Range("W4:W1004")
        If IsNull(.DisplayFormat.Interior.ColorIndex) Then
            MsgBox "Complete missing manufacturer's information"
            Exit Sub
        End If
    End With


Sheets("Std").Copy
With ActiveSheet.UsedRange
    .Value = .Value
End With

 

[Rahulkr]

Dear mikerickson,

I have went through your code, it's quiet impressive and got an idea what I want, any how I am a beginner to VBA, and I was trying to achieve one goal on the basis of your code, but some how I was not able to achieve what I want, could you please look into the code and help me out. for reference please find attached image file and code also also. So, you could understand what I want.

[/B]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.DisplayAlerts() = False
Application.ScreenUpdating = False

    If Range("Q6") = Range("Q9") And Range("Q7") = Range("Q10") Then ' To check number of staffs comming and going with picked staffs and drop.
        MsgBox "Number of coming staffs were matched with pick and drop entries, click ok to check duplicate entries.", vbOKOnly, ""
        bTemp = Application.Dialogs(xlDialogPrint).Show
Else
        MsgBox "Number of coming staffs were not matched. Check Schedule Properly or generate mail for additional car required by chosing Car Type", vbOKOnly, " "

        End If

Next
Sub a()

Dim left As Integer
Dim right As Integer

Dim i As Integer
Dim k As Integer

Dim wsSch As Worksheet: Set wsSch = Worksheets("Schedule")
Dim wsList As Worksheet: Set wsList = Worksheets("EMPLOYEE MASTER")

Dim comingS As Integer: comingS = wsSch.Cells(9, 17).Value
Dim outgoingS As Integer: outgoingS = wsSch.Cells(10, 17).Value

If comingS <> outgoingS Then
    MsgBox "Num of staffs coming to office and leaving is mismatched" & vbCr & "Coming staffs:" & vbTab & comingS & vbCr & _
            "Leaving staffs:" & vbTab & outgoingS & vbCr
End If
Next
Sub test()
    Dim oneCell As Range, newNote As String

    For Each oneCell In Range("E6:E21,K6:K25,C6:C21,I6:I25")
        With oneCell
            If oneCell.DisplayFormat.Interior.Color = vbRed Then
                newNote = Application.InputBox("Enter a comment in " & .Address, Default:=.NoteText)
                If newNote = "False" Then
                MsgBox "Num of staffs coming to office and leaving is mismatched" & vbCr & "Coming staffs:" & vbTab & comingS & vbCr & _
            "Leaving staffs:" & vbTab & outgoingS & vbCr
                    Exit For
                Else
                    .NoteText newNote
                End If
            End If
        End With
    Next oneCell
End Sub

[B]

 

[Rahulkr]

Please help me out on this

Another way for you to handle this is to simply alert the user that one or more cells do not have the required note in them and let the user find the red cell on their own. Doing it this way allows you to avoid looping through the cells one cell at a time in code looking for the red cell... the cell is red so the user should be able to find it quite easily. Here is the code to do it this way...

[table="width: 500"]
[tr]
    [td]Sub RedCellRequiresComment()
  With Range("D3:P1004")
    If IsNull(.DisplayFormat.Interior.ColorIndex) Then
      MsgBox "One (or more) of the cells in Range D3:P1004 is colored red indicating they require you to put a note in it (them)."
      Exit Sub
    End If
  End With
End Sub[/td]
[/tr]
[/table]

Hello Sir,
I am having Cell ranges from =$C$6:$C$21,$I$6:$I$25 and =$E$6:$E$21,$K$6:$K$25 with conditional formatting to find duplicate values. if duplicate values found then the cell color will become red.

Sir, can you please provide coding on this and where should i keep the coding in sheet with below code also.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.DisplayAlerts() = False
Application.ScreenUpdating = False

If Range("Q6") = Range("Q9") And Range("Q7") = Range("Q10") Then ' To check number of staffs comming and going with picked staffs and drop.
MsgBox "Number of coming staffs were matched with pick and drop entries, click ok to check duplicate entries.", vbOKOnly, ""
bTemp = Application.Dialogs(xlDialogPrint).Show
Else
MsgBox "Number of coming staffs were not matched. Check Schedule Properly or generate mail for additional car required by chosing Car Type", vbOKOnly, " "

End If

End Sub