VBA - highlight consecutive

[mahmed1]

Hi, I am really hoping someone can help me with some VBA code that can help me with this as ive had no luck with a previous thread

I have a row of data

Say B6 (I have % target variable) ie >70%
In D6 (I have consecutive day target 3)
In E6 (to last column as data will get added in column and each day) i have the data

What i want the VBA code to do is if the value from E6 to last column is
More than target % and has remained like that for more than or = to consecutive day target then highlight that value red colour...

Eg if the values are
69, 67,68,71,70,71 (highlight 71), 77, (highlight 77), 55,67,78,78,60,61,70,71,77 (highlight 77), 78 (highlight 78), 75 (highlight 75)

I hope this makes sense and really hope someone can help me

The other thing i have is in row E3 i have the dates listed..... I want to have a macro that filters by days
So say i had a macro to only display mondays data (i can loop through to hide other columns and just show mondays columns) and then what if want the highlight code to is still check for the condition but look at the visible cells

So only look at the visible columns from E3 and look at the condition and highlight

Please can someone help me with this

Thank You

 

[Peter_SSs]

Are the blanks always at the right of the data in the row or can blanks be scattered throughout the data in a row?
Are the blanks completely empty cells or cells containing a formula that returns ""?

 

[mahmed1]

Hiya the blanks will be a formula that returns ""

Blanks will be blank at the end of the data but will be a formula returning those blanks

 

[Peter_SSs]

Try _v4. Three changed lines highlighted.

Sub Highlight_Metrics_v4()
  Dim LastCol As Long, LastRow As Long, r As Long, c As Long, ConsecL As Long, ConsecM As Long, ConsecH As Long, k As Long
  Dim dLow As Double, dHigh As Double
  Dim rHL As Range, rHM As Range, rHH As Range
  
  LastCol = Cells(5, Columns.Count).End(xlToLeft).Column
  LastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Range("H6", Cells(LastRow, LastCol)).Interior.Color = xlNone
  For r = 6 To LastRow
    Set rHL = Range("A1")
    Set rHM = Range("A1")
    Set rHH = Range("A1")
    k = 0
    If IsNumeric(Range("B" & r).Value) Then dLow = Range("B" & r).Value
    dHigh = Range("C" & r).Value
    ConsecL = Range("D" & r).Value
    ConsecM = Range("E" & r).Value
    ConsecH = Range("F" & r).Value
    Select Case Range("G" & r).Value
      Case "Metric 1"
        For c = 8 To LastCol
          If Not Columns(c).Hidden Then
            If (Cells(r, c).Value < dLow Or Cells(r, c).Value > dHigh) And Len(Cells(r, c).Value) > 0 Then
              k = k + 1
              Select Case k
                Case Is >= ConsecH: Set rHH = Union(rHH, Cells(r, c))
                Case Is >= ConsecM: Set rHM = Union(rHM, Cells(r, c))
                Case Is >= ConsecL: Set rHL = Union(rHL, Cells(r, c))
              End Select
            Else
              k = 0
            End If
          End If
        Next c
      Case "Metric 2"
        For c = 8 To LastCol
          If Not Columns(c).Hidden Then
            If Cells(r, c).Value > dHigh And Len(Cells(r, c).Value) > 0 Then
              k = k + 1
              Select Case k
                Case Is >= ConsecH: Set rHH = Union(rHH, Cells(r, c))
                Case Is >= ConsecM: Set rHM = Union(rHM, Cells(r, c))
                Case Is >= ConsecL: Set rHL = Union(rHL, Cells(r, c))
              End Select
            Else
              k = 0
            End If
          End If
        Next c
      Case "Metric 4"
        For c = 8 To LastCol
          If Not Columns(c).Hidden Then
            If Cells(r, c).Value < dHigh And Len(Cells(r, c).Value) > 0 Then
              k = k + 1
              Select Case k
                Case Is >= ConsecH: Set rHH = Union(rHH, Cells(r, c))
                Case Is >= ConsecM: Set rHM = Union(rHM, Cells(r, c))
                Case Is >= ConsecL: Set rHL = Union(rHL, Cells(r, c))
              End Select
            Else
              k = 0
            End If
          End If
        Next c
    End Select
    If rHL.Cells.Count > 1 Then Intersect(rHL, Rows("6:" & LastRow)).Interior.Color = 65535
    If rHM.Cells.Count > 1 Then Intersect(rHM, Rows("6:" & LastRow)).Interior.Color = 8696052
    If rHH.Cells.Count > 1 Then Intersect(rHH, Rows("6:" & LastRow)).Interior.Color = 192
  Next r
End Sub

 

[mahmed1]

Thank you so much

 

[Peter_SSs]

Thank you so much