find specific pattern cells in Excel

[anand3dinesh]

Dear aAll,

Please see attached image, i need VBA code that identifies Yellow filled and hatched cell and mark it as Y in Flag Column.
Any help please?

 

[maabadi]

Hi.
I Suppose Your Yellow Color is RGB(255,255,0) & Your Hatched is 25%Gray , Then this is code:

Sub FindYellowHatchedCells()
Dim MyRange As Range
Dim Lastrow As Long
Dim Cell As Range

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRange = Range("A2:A" & Lastrow)
For Each Cell In MyRange
 If Cell.Interior.Color = RGB(255, 255, 0) Then
     If Cell.Interior.Pattern = xlPatternGray25 Then
       Cell.Offset(0, 1).Value = "Y"
     Else
       Cell.Offset(0, 1).Value = ""
     End If
    
 End If

Next Cell

End Sub

 

[anand3dinesh]

T

Hi.
I Suppose Your Yellow Color is RGB(255,255,0) & Your Hatched is 25%Gray , Then this is code:

Sub FindYellowHatchedCells()
Dim MyRange As Range
Dim Lastrow As Long
Dim Cell As Range

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRange = Range("A2:A" & Lastrow)
For Each Cell In MyRange
If Cell.Interior.Color = RGB(255, 255, 0) Then
     If Cell.Interior.Pattern = xlPatternGray25 Then
       Cell.Offset(0, 1).Value = "Y"
     Else
       Cell.Offset(0, 1).Value = ""
     End If
   
End If

Next Cell

End Sub

Thanks for you Help. i have a question check below line, there will be no data in this column except color fill and hacth cells. how could .End(xlUp) will work?

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

 

[maabadi]

Sorry anand3dinesh . I think you have Data in Range. Then Use This. Code continue until found a cell with No Color.

Sub FindYellowHatchedCells()
Dim MyRange As Range
Dim StartRow As Long
Dim Cell As Range
Dim i As Long

StartRow = Range("H2").Row
For i = StartRow To 65536
If Cells(i, 8).Interior.Color <> RGB(255, 255, 255) Then
 If Cells(i, 8).Interior.Color = RGB(255, 255, 0) Then
     If Cells(i, 8).Interior.Pattern = xlPatternGray25 Then
       Cells(i, 9).Value = "Y"
     Else
       Cells(i, 9).Value = ""
     End If
   Debug.Print Cells(i, 8).Address
 End If
 
Else
 Exit Sub
End If
Next i

End Sub

​

 

[anand3dinesh]

Sorry anand3dinesh . I think you have Data in Range. Then Use This. Code continue until found a cell with No Color.

Sub FindYellowHatchedCells()
Dim MyRange As Range
Dim StartRow As Long
Dim Cell As Range
Dim i As Long

StartRow = Range("H2").Row
For i = StartRow To 65536
If Cells(i, 8).Interior.Color <> RGB(255, 255, 255) Then
If Cells(i, 8).Interior.Color = RGB(255, 255, 0) Then
     If Cells(i, 8).Interior.Pattern = xlPatternGray25 Then
       Cells(i, 9).Value = "Y"
     Else
       Cells(i, 9).Value = ""
     End If
   Debug.Print Cells(i, 8).Address
End If

Else
Exit Sub
End If
Next i

End Sub

​

Thanks Mate, That Worked

 

[Peter_SSs]

I see that you already have a suitable answer and I don't know how big your range to check is likely to be but here is an alternative that should do the job without cycling through & checking row-by-row. This code will also work for all relevant cells in the column even if cells with no colour exist between the coloured cells.

Sub MarkYellowHatch()
  Dim rngLastYellowHatch As Range

  With Application
    .ScreenUpdating = False
    .FindFormat.Clear
    With .FindFormat.Interior
     .Pattern = xlGray25
     .PatternColorIndex = xlAutomatic
     .Color = vbYellow
    End With
    Set rngLastYellowHatch = Columns("A").Find(What:="", SearchDirection:=xlPrevious, SearchFormat:=True)
    If Not rngLastYellowHatch Is Nothing Then
      With Range("A1", rngLastYellowHatch)
        .AutoFilter Field:=1, Criteria1:=RGB(0, 0, 0), Operator:=xlFilterCellColor
        With ActiveSheet.AutoFilter.Filters(1).Criteria1
          .Pattern = xlGray25
          .Color = vbYellow
        End With
        .Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value = "Y"
      End With
      ActiveSheet.AutoFilterMode = False
    End If
    .FindFormat.Clear
    .ScreenUpdating = True
  End With
End Sub

 

[anand3dinesh]

I see that you already have a suitable answer and I don't know how big your range to check is likely to be but here is an alternative that should do the job without cycling through & checking row-by-row. This code will also work for all relevant cells in the column even if cells with no colour exist between the coloured cells.

Sub MarkYellowHatch()
  Dim rngLastYellowHatch As Range

  With Application
    .ScreenUpdating = False
    .FindFormat.Clear
    With .FindFormat.Interior
     .Pattern = xlGray25
     .PatternColorIndex = xlAutomatic
     .Color = vbYellow
    End With
    Set rngLastYellowHatch = Columns("A").Find(What:="", SearchDirection:=xlPrevious, SearchFormat:=True)
    If Not rngLastYellowHatch Is Nothing Then
      With Range("A1", rngLastYellowHatch)
        .AutoFilter Field:=1, Criteria1:=RGB(0, 0, 0), Operator:=xlFilterCellColor
        With ActiveSheet.AutoFilter.Filters(1).Criteria1
          .Pattern = xlGray25
          .Color = vbYellow
        End With
        .Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value = "Y"
      End With
      ActiveSheet.AutoFilterMode = False
    End If
    .FindFormat.Clear
    .ScreenUpdating = True
  End With
End Sub

View attachment 27429

Thanks Mate, this works great.
apologies i am repling you late

 

[Peter_SSs]

You're welcome. Follow-up any time is appreciated.