VBA code needed to highlight all positive consecutive integers in rows with count of 7 or greater

[mr_king]

Hello,

I'm looking for VBA code to highlight all consecutive positive integers in rows with consecutive counts greater than 7. It is to be left open ended to add additional data by rows and columns. It should start in Column G20.

example:

[/IMG]

Thanks!

 

[mr_king]

Hello,

I'm looking for VBA code to highlight all consecutive positive integers in rows with consecutive counts greater than 7. It is to be left open ended to add additional data by rows and columns. It should start in Column G20.

example:

[/IMG]

Thanks!

 

[mr_king]

**EXAMPLE IMAGE CORRECTED BELOW**

[/IMG]

 

[Rick Rothstein]

I believe this macro will do what you asked for...

[table="width: 500"]
[tr]
	[td]Sub SevenOrMorePositivesPerRow()
  Dim R As Long, C As Long
  For R = 1 To Cells(Rows.Count, "A").End(xlUp).Row
    For C = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 6
      If Application.CountIf(Cells(R, C).Resize(, 7), "<1") = 0 Then Cells(R, C).Resize(, 7).Interior.Color = vbYellow
    Next
  Next
End Sub[/td]
[/tr]
[/table]

 

[mr_king]

Rick, Works great, thank you!

I have one other request using the same logic above as greater than 7:

If I wanted to highlight the first 6 consecutive count positives as a different color and leave the 7th and larger left at yellow. How could that be written in VBA?


Thanks!

 

[Rick Rothstein]

If I wanted to highlight the first 6 consecutive count positives as a different color and leave the 7th and larger left at yellow. How could that be written in VBA?

Give this a try...

[table="width: 500"]
[tr]
	[td]Sub SevenOrMorePositivesPerRow()
  Dim R As Long, C As Long, StartSix As Range
  For R = 1 To Cells(Rows.Count, "A").End(xlUp).Row
    For C = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 6
      If Application.CountIf(Cells(R, C).Resize(, 7), "<1") = 0 Then
        If StartSix Is Nothing Then Set StartSix = Cells(R, C)
        Cells(R, C).Resize(, 7).Interior.Color = vbYellow
      End If
    Next
    If Not StartSix Is Nothing Then StartSix.Resize(, 6).Interior.Color = 11851260
    Set StartSix = Nothing
  Next
End Sub[/td]
[/tr]
[/table]

 

[mr_king]

Thank you Rick, one issue though...

If there are multiple sets of consecutive positives greater than 7 on the same row, only the first set is highlighting the first 6 as orange in your above vba code. Is there a way so that all consecutive sets will highlight the first 6 as orange on the same row?

Thanks!

 

[Peter_SSs]

It should start in Column G20.

If there are multiple sets of consecutive positives greater than 7 on the same row,... Is there a way so that all consecutive sets will highlight the first 6 as orange on the same row?

This is an alternative approach that I believe does what you want & allows you to specify where the data starts (G20 in your example), how many consecutives you want to look for (minimum of 7) and how many at the start to colour differently (6).
It also
- clears any existing colour from the range (in case the code has been run before but the data has changed)
- is considerably faster than the previously suggested code, though that would only be relevant if your data is very large.

Sub Highlight_Consecutive_Positives()
  Dim a As Variant
  Dim i As Long, j As Long, k As Long, cStart As Long, cols As Long
  Dim rTL As Range
  
  Const MinNum As Long = 7    '<- Set minimum number of consecutive positives
  Const FirstN As Long = 6    '<- First how many a different colour
  Const TL As String = "G20"  '<- Address of top left cell
  
  Application.ScreenUpdating = False
  Set rTL = Range(TL)
  With Range(rTL, Cells(Rows.Count, rTL.Column).End(xlUp)).Resize(, Cells(rTL.Row, Columns.Count).End(xlToLeft).Column - rTL.Column + 2)
    .Interior.Color = xlNone
    cols = .Columns.Count
    a = .Value
    For i = 1 To UBound(a)
      For j = 1 To cols
        If a(i, j) > 0 Then
          k = k + 1
          If k = 1 Then cStart = j
        Else
          If k >= MinNum Then
            .Cells(i, cStart).Resize(, k).Interior.Color = vbYellow
            .Cells(i, cStart).Resize(, FirstN).Interior.Color = 49407
          End If
          k = 0
        End If
      Next j
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

 

[mr_king]

Works great! Thank you Pete & Rick!

 

[Peter_SSs]

Works great! Thank you Pete & Rick!

You’re welcome - glad to contribute.