Looping array to highlight / colour sequential zeros

[Capt_Antihero]

Hello,

I have 4 columns with data H, I, J and K. I need to write a macro that will search through H, starting at H14 and look for a single 0 (zero) in all cells with data in column H starting from H14. This is where I get a bit stuck as I don't know how to add IF functions through arrays.

So as example if H27 has a 0 and only a zero, I need it to check the cell next to it so offset check to I27, and if I27 has a single zero I need it to check J27 so offset again and if J27 has a single zero then I would like all those cells H27, I27, J27 and also the next offset K27 to interior colour yellow. Now because that isn't difficult enough for a novice like me, if all of the above rains true and H27:K27 are all yellow H27:J27 had a single zero in their cells, I would like the contents of K27 to copy to F12.

I know how to do this if I knew the location of the zeros but as my data could be 1000 rows and there could only be 1 row that has the single 0 (zero) in cells H, I and J I need to know how to look through my arrary of data and apply the if sequence / offset as above. If anyone can help me, then that would be amazing...?

 

[Capt_Antihero]

The code I have is below, but all it does is find all the single 0 cells in my range and change their colour to yellow. I want to only do this if all 3 columns I am looking through have a single zero and then of course I need to colour the next cell offset and copy that data to a new cell.

Sub Color_cells()
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As Range
Dim I As Long
Dim sh As Worksheet
MySearch = Array("0")
myColor = Array("6")

For Each sh In ActiveWorkbook.Worksheets
With sh.Range("H14:J1000")
For I = LBound(MySearch) To UBound(MySearch)

Set Rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do

Rng.Interior.ColorIndex = myColor(I)
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
Next sh
End Sub

 

[Capt_Antihero]

Hello all, for those that viewed this, I ended up solving it in a really low tech way the code is as follows:

Sub Color_cells()
Dim rng As Range
Dim i As Long



Set rng = Range("H14:H1000")
For Each cell In rng

If cell.Value = "0" And cell.Offset(0, 1).Value = "0" And cell.Offset(0, 2).Value = "0" Then
cell.Offset(0, 1).Interior.ColorIndex = 6
End If
If cell.Offset(0, 1).Interior.ColorIndex = 6 Then
cell.Offset(0, 2).Interior.ColorIndex = 6
End If
If cell.Offset(0, 2).Interior.ColorIndex = 6 Then
cell.Offset(0, 0).Interior.ColorIndex = 6
End If
If cell.Offset(0, 0).Interior.ColorIndex = 6 Then
cell.Offset(0, 3).Interior.ColorIndex = 6
End If
If cell.Offset(0, 3).Interior.ColorIndex = 6 Then
Sheets("Sheet1").Range("F12") = cell.Offset(0, 3).Value
End If
Next

End Sub

Basically because I need all 3 cells to have a zero I could start the code to just look through the first column (no array needed) then if a cell in my range had the value of zero and the first offset was 0 and the second offset was 0 I could color a cell. Then I worked backwards and applied the same logic, if the cell was a color then color the offset, lastly if the final cell I needed was color then I selected that cell's value and applied it where I needed it.

Thanks to everyone who may have looked at this. I am sure there is a far better and more intelligent method to doing what I needed, but this works for me and I am on a serious time crunch.

James.

 

[Stridhan]

Heres one to try. Dynamic lastrow instead of looping true an empty range.

Try:

Sub Color_cells()


Dim i, lrow As Integer
lrow = ActiveSheet.Cells(Rows.Count, 8).End(xlUp).Row


For i = 14 To lrow
    If ActiveSheet.Cells(i, 8).Value = "0" Then
        If ActiveSheet.Cells(i, 9).Value = "0" Then
            If ActiveSheet.Cells(i, 10).Value = "0" Then
                ActiveSheet.Cells(i, 8).Resize(1, 4).Interior.ColorIndex = 6
            End If
        End If
    End If
Next i


End Sub

 

[brian.wethington]

I myself would prefer to avoid the loop if at all possible. I can't tell for sure everything you want to perform, but this seems to work for me at getting the first instance (address and value), as well as coloring all instances. If you were trying to pull data on the last instance only, it can be adjusted to find that.

Sub ColorCellsAutofilter()
Dim chRange As Range, afRange As Range

With Sheets("Sheet1")
    Set afRange = .Range("H13", .Range("K" & Rows.Count).End(xlUp))
    Set chRange = Intersect(afRange, afRange.Offset(1))
    With afRange
        .AutoFilter field:=1, Criteria1:="0"
        .AutoFilter field:=2, Criteria1:="0"
        .AutoFilter field:=3, Criteria1:="0"
        'Assuming there are headers in row 13 and there are no instances found this will keep from error
        If Cells(Rows.Count, 8).End(xlUp).Row = 13 Then
            MsgBox "No instances found, procedure made no changes", , "No Instance"
            .AutoFilter
            Exit Sub
        End If
        Set chRange = chRange.SpecialCells(xlCellTypeVisible)
        chRange.Interior.ColorIndex = 6
        .AutoFilter
    End With
    'Show first instance address in f11 and first instance value in f12
    .Range("F12") = chRange.Cells(1, 4)
    .Range("F11") = chRange.Cells(1, 4).Address
End With
End Sub

If there is another reason you are stuck on the looping idea the following provides both first and last instance:

Sub ColorCells2()
Dim chRange As Range, cLoop As Range, i As Long

i = 0
With Sheets("sheet1")
    Set chRange = .Range("H14", .Range("H" & Rows.Count).End(xlUp))
    For Each cLoop In chRange
        If cLoop = "0" Then
            If cLoop.Offset(, 1) = "0" Then
                If cLoop.Offset(, 2) = "0" Then
                    cLoop.Resize(, 4).Interior.ColorIndex = 6
                    i = i + 1
                    If i = 1 Then 'Shows only the first occurring instance Address F11 and Value in F12
                        .Range("F12") = cLoop.Offset(, 3).Value
                        .Range("F11") = cLoop.Offset(, 3).Address
                    End If
                    'Show the final occurring instance Address [G11] and value [G12]
                    .Range("G12") = cLoop.Offset(, 3).Value
                    .Range("G11") = cLoop.Offset(, 3).Address
                End If
            End If
        End If
    Next
End With
End Sub

 

[Stridhan]

Brian,
If i use the one without loops and only have a 0 in first column, it get an error.
Is there a walkaround on that with this method?

/Stridhan

 

[brian.wethington]

Yeah, I should have taken that a step further in my tests.

Sub ColorCellsAutofilter()
Dim chRange As Range, afRange As Range

On Error GoTo NoInstance
With Sheets("Sheet1")
    Set afRange = .Range("H13", .Range("K" & Rows.Count).End(xlUp))
    Set chRange = Intersect(afRange, afRange.Offset(1))
    With afRange
        .AutoFilter field:=1, Criteria1:="0"
        .AutoFilter field:=2, Criteria1:="0"
        .AutoFilter field:=3, Criteria1:="0"
        Set chRange = chRange.SpecialCells(xlCellTypeVisible)
        chRange.Interior.ColorIndex = 6
        .AutoFilter
    End With
    'Show first instance address in f11 and first instance value in f12
    .Range("F12") = chRange.Cells(1, 4)
    .Range("F11") = chRange.Cells(1, 4).Address
End With
Exit Sub
NoInstance:
    MsgBox "No instances found, procedure made no changes", , "No Instance"
    chRange.AutoFilter
End Sub

Thanks for the catch.

 

[Stridhan]

Thanks for showing this great approach!