Find consecutive cells with specific cell formatting.

[katana_flyer]

Looking for a way to search for 3 consecutive cells within the whole sheet, either vertically, horizontally or diagonally, with same cell formatting. ie. If cell a1,a2, a3 Or cells a1,b1,c1 Or cells a1,b2, c3 all receive red fill, then a msgBox. Displays.

Many thanks

 

[DanteAmor]

Try this

Sub FindColors()
  Dim c As Range, cad As String
  On Error Resume Next
  For Each c In ActiveSheet.UsedRange
    If c.Interior.Color = vbRed And c.Offset(0, 1).Interior.Color = vbRed And c.Offset(0, 2).Interior.Color = vbRed Then
      cad = c.Address & " " & c.Offset(0, 1).Address & " " & c.Offset(0, 2).Address
    End If
    If c.Interior.Color = vbRed And c.Offset(1, 1).Interior.Color = vbRed And c.Offset(2, 2).Interior.Color = vbRed Then
      cad = c.Address & " " & c.Offset(1, 1).Address & " " & c.Offset(2, 2).Address
    End If
    If c.Interior.Color = vbRed And c.Offset(1, 0).Interior.Color = vbRed And c.Offset(2, 0).Interior.Color = vbRed Then
      cad = c.Address & " " & c.Offset(1, 0).Address & " " & c.Offset(2, 0).Address
    End If
    If c.Interior.Color = vbRed And c.Offset(-1, 1).Interior.Color = vbRed And c.Offset(-2, 2).Interior.Color = vbRed Then
      cad = c.Address & " " & c.Offset(-1, 1).Address & " " & c.Offset(-2, 2).Address
    End If
    If cad <> "" Then
      MsgBox "Consecutive cells  : " & Replace(cad, "$", "")
      Exit Sub
    End If
  Next
End Sub

 

[katana_flyer]

Thank you DanteAmor, that did the trick.... almost , I had to change a few things to make it work the way I want. Now I ran into a wee problem.

This code works perfectly fine - once it finds 5 cells in a row diagonally with the either red or green cells, it highlights them all green ~ Just the way I want it to.

Dim c As Range, cad As String
On Error Resume Next
For Each c In ActiveSheet.UsedRange

' Check for Diagonal Row from top left to bottom right and Color green
If (c.Interior.Color = vbRed Or c.Interior.Color = vbGreen) And (c.Offset(1, 1).Interior.Color = vbRed Or c.Offset(1, 1).Interior.Color = vbGreen) And (c.Offset(2, 2).Interior.Color = vbRed Or c.Offset(2, 2).Interior.Color = vbGreen) And (c.Offset(3, 3).Interior.Color = vbRed Or c.Offset(3, 3).Interior.Color = vbGreen) And (c.Offset(4, 4).Interior.Color = vbRed Or c.Offset(4, 4).Interior.Color = vbGreen) Then
c.Interior.Color = RGB(0, 255, 0)
c.Offset(1, 1).Interior.Color = RGB(0, 255, 0)
c.Offset(2, 2).Interior.Color = RGB(0, 255, 0)
c.Offset(3, 3).Interior.Color = RGB(0, 255, 0)
c.Offset(4, 4).Interior.Color = RGB(0, 255, 0)

End If
Next

but as soon as I add in this code, to search for 5 consecutive green or red cells diagonally from top right to bottom left it decides to fill in range a1 to d57 with green cells. Even if there is only 1 cell anywhere on the sheet coloured red or green. Any insight ? Thanks

' check for diagonal row from top right down to top left and color green **
If (c.Interior.Color = vbRed Or c.Interior.Color = vbGreen) And (c.Offset(1, -1).Interior.Color = vbRed Or c.Offset(1, -1).Interior.Color = vbGreen) And (c.Offset(2, -2).Interior.Color = vbRed Or c.Offset(2, -2).Interior.Color = vbGreen) And (c.Offset(3, -3).Interior.Color = vbRed Or c.Offset(3, -3).Interior.Color = vbGreen) And (c.Offset(4, -4).Interior.Color = vbRed Or c.Offset(4, -4).Interior.Color = vbGreen) Then
c.Interior.Color = RGB(0, 255, 0)
c.Offset(1, -1).Interior.Color = RGB(0, 255, 0)
c.Offset(2, -2).Interior.Color = RGB(0, 255, 0)
c.Offset(3, -3).Interior.Color = RGB(0, 255, 0)
c.Offset(4, -4).Interior.Color = RGB(0, 255, 0)
End If


Next

 

[DanteAmor]

that did the trick.... almost

In the original post you requested for 3 cells.
Does the macro work for 3 cells?
If so, follow the same pattern for 5 cells.

 

[katana_flyer]

I've altered the original to look for 5 instead of 3., and to color them instead of displaying a msgbox. The original one you sent me works perfectly fine for going horizontally or vertically or for diagonally in this direction \ but when I reverse it by adding negative values in offset, to go diagonally this way / it goes crazy with filing in cells when the macro is ran, even if there is not 5 in a row diagonally. The problem only happens when using negative values. Works great otherwise if I take out that section of code causing the issue.

 

[katana_flyer]

the problem is somewhere in this code. when this code alone runs, a bunch of cells fill in with green

Dim c As Range, cad As String

On Error Resume Next
For Each c In Range("c4:s15")

'********** check if diagonal row of 5 cells with either green or red fill exist, if so, fill that 5 in with green ************
If (c.Interior.Color = vbRed Or c.Interior.Color = vbGreen) And (c.Offset(1, -1).Interior.Color = vbRed Or c.Offset(1, -1).Interior.Color = vbGreen) And (c.Offset(2, -2).Interior.Color = vbRed Or c.Offset(2, -2).Interior.Color = vbGreen) And (c.Offset(3, -3).Interior.Color = vbRed Or c.Offset(3, -3).Interior.Color = vbGreen) And (c.Offset(4, -4).Interior.Color = vbRed Or c.Offset(4, -4).Interior.Color = vbGreen) Then
c.Offset(4, -4).Interior.Color = RGB(0, 255, 0)
c.Offset(3, -3).Interior.Color = RGB(0, 255, 0)
c.Offset(2, -2).Interior.Color = RGB(0, 255, 0)
c.Offset(1, -1).Interior.Color = RGB(0, 255, 0)
c.Interior.Color = RGB(0, 255, 0)
End If
Next
End Sub

 

[DanteAmor]

Apparently VBA has problems with the If of more than 3 conditions. I changed it to 3 and 2.

Try this:

Sub changeColor2()
  Dim c As Range
  
  On Error Resume Next
  For Each c In Range("C4:S15")
    '********** check if diagonal row of 5 cells with either green or red fill exist, if so, fill that 5 in with green ************
    
    If (c.Interior.Color = vbRed Or c.Interior.Color = vbGreen) And _
       (c.Offset(1, -1).Interior.Color = vbRed Or c.Offset(1, -1).Interior.Color = vbGreen) And _
       (c.Offset(2, -2).Interior.Color = vbRed Or c.Offset(2, -2).Interior.Color = vbGreen) Then
       
      If (c.Offset(3, -3).Interior.Color = vbRed Or c.Offset(3, -3).Interior.Color = vbGreen) And _
         (c.Offset(4, -4).Interior.Color = vbRed Or c.Offset(4, -4).Interior.Color = vbGreen) Then
        If Err.Number = 0 Then
          c.Interior.Color = RGB(0, 255, 0)
          c.Offset(1, -1).Interior.Color = RGB(0, 255, 0)
          c.Offset(2, -2).Interior.Color = RGB(0, 255, 0)
          c.Offset(3, -3).Interior.Color = RGB(0, 255, 0)
          c.Offset(4, -4).Interior.Color = RGB(0, 255, 0)
        End If
      End If
      
    End If
  Next
End Sub