VBA - highlight consecutive

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I tried adapting the code without getting the right out put :(

I am retyping with my phone therefore i really apologise if the format aint right

i added extra consec variables and shighlight variables as well as changing the start from column F to H

I tried spreading out the lines just to format it right on my phone to show the changes i tried to apply- im sure no doubt you would probably spot my mistake and approached it differently

thank you and i look forward to your solution- your a legend

Sub Highlight_Metrics_v2()
Dim LastCol As Long, LastRow As Long, r As Long, c As Long,
Consec As Long,
Consec2 as Long,
Consec3 as Long,
k As Long
Dim dLow As Double, dHigh As Double

Dim sHighlight As String
Dim sHighlight2 As String
Dim sHighlight3 as String

LastCol = Cells(5, Columns.Count).End(xlToLeft).Column
LastRow = Cells(Rows.Count, "G").End(xlUp).Row
Range("H”, Cells(LastRow, LastCol)).Interior.Color = xlNone
For r = 6 To LastRow
sHighlight = vbNullString
k = 0
If IsNumeric(Range("B" & r).Value) Then dLow = Range("B" & r).Value
dHigh = Range("C" & r).Value

Consec = Range("D" & r).Value
Consec2 = Range("E” & r).Value
Consec3 = Range("F” & r).Value

Select Case Range("G” & r).Value
Case "Metric 1"
For c = 6 To LastCol
If Not Columns(c).Hidden Then
If Cells(r, c).Value < dLow Or Cells(r, c).Value > dHigh Then
k = k + 1
Select Case k
Case Is k >= Consec Then sHighlight = sHighlight & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec2 Then sHighlight2 = sHighlight2 & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec3 Then sHighlight3 = sHighlight3 & "," & Cells(r, c).Address(0, 0)

Case Else
k = 0
End Select

End If
End If
Next c
Case "Metric 2"
For c = 6 To LastCol
If Not Columns(c).Hidden Then
If Cells(r, c).Value > dHigh Then
k = k + 1

Select Case k
Case Is k >= Consec Then sHighlight = sHighlight & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec2 Then sHighlight2 = sHighlight2 & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec3 Then sHighlight3 = sHighlight3 & "," & Cells(r, c).Address(0, 0)

Case Else
k = 0
End Select

End If
End If
Next c
Case "Metric 4"
For c = 6 To LastCol
If Not Columns(c).Hidden Then
If Cells(r, c).Value < dHigh Then
k = k + 1
Select Case k
Case Is k >= Consec Then sHighlight = sHighlight & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec2 Then sHighlight2 = sHighlight2 & "," & Cells(r, c).Address(0, 0)

Case Is k >= Consec3 Then sHighlight3 = sHighlight3 & "," & Cells(r, c).Address(0, 0)

Case Else
k = 0
End Select

End If
End If
Next c
End Select

If Len(sHighlight) > 0 Then Range(Mid(sHighlight, 2)).Interior.Color = vbYellow

If Len(sHighlight2) > 0 Then Range(Mid(sHighlight2, 2)).Interior.Color = vbOrange

If Len(sHighlight3) > 0 Then Range(Mid(sHighlight3, 2)).Interior.Color = vbRed

Next r
End Sub
 

Some videos you may like

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,786
Office Version
  1. 365
Platform
  1. Windows
i dont how hard this will be in to add and whether i can easily tweak your code to achieve this but it will be awesome if i can do this

if i added 2 more consecutive days columns added After Column D (so D, E, F)

so in I might have , 3,5,7
Is it possible to have the exact same code as above but if the consec days hits >= to D then highlight 1 colour and if it hits >= E then highlight a another colour and if >= F then say a Red colour

what im trying to do Is use your exact same code and logic but if it hits more than x amount amount consec days then highlight a different colour
I don't know how feasible this is. Once again, could we have some sample data and expected results that show the variety of situations that might occur. If it still involves hidden columns, make sure that some are hidden so that we can see just how that works.
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi I've attached the example below

you can see when it hits 3 days consec its Yellow, 4-5 orange and >=6 it gets red following your same logic

Thank you once again

VarianceConsecutive Days LowConsecutive Days MediumConsecutive Days HighMetric28/09/202029/09/202002/10/202003/10/202005/10/202006/10/202007/10/202008/10/202012/10/202013/10/202014/10/202015/10/202016/10/202017/10/202018/10/202019/10/202020/10/202021/10/2020
-20.00%20.00%346Metric 119.62%-19.17%-86.29%-70.82%-44.51%-65.48%66.67%-59.60%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%
>500346Metric 25065015075085015025025026501501501506506501131415
<90.00%346Metric 490.0%90.0%85.0%85.0%85.0%89.0%89.5%89.5%90.0%85.0%85.0%85.0%85.0%85.0%85.0%85.0%85.0%89.0%
000001110111111111
Low
Medium
High
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
the columns that have no values were actually hidden columns
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Your code worked beautifully but ive just noticed that if the consec days is over so many days the colour interior part fails

i get this message run time error 1004 (method range of object global failed)

,M18,N18,O18,X18,Y18,Z18,AA18,AB18,AC18,AD18,AE18,AF18,AG18,AH18,AI18,AJ18,AK18,AL18,AM18,AN18,AO18,AP18,AQ18,AR18,AS18,AT18,AU18,AV18,AW18,AX18,AY18,AZ18,BA18,BB18,BC18,BD18,BE18,BF18,BG18,BH18,BI18,BJ18,BK18,BL18,BM18,BN18,BO18,BP18,BQ18,BR18,BS18,BT18,BU18,BV18,BW18,BX18,BY18,BZ18,CA18,CB18,CC18
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,786
Office Version
  1. 365
Platform
  1. Windows
Try this version. It does not give exactly the same results as you have in post 23 but I am assuming you made a mistake in starting your yellow highlight on 03/10/2020 in the first row when that is only the second value meeting the criteria?

VBA Code:
Sub Highlight_Metrics_v3()
  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 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 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 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


My results:

mahmed1.xlsm
BCDEFGHILMOPQRVWXYZAAABACADAE
5VarianceConsecutive Days LowConsecutive Days MediumConsecutive Days HighMetric28/09/202029/09/20202/10/20203/10/20205/10/20206/10/20207/10/20208/10/202012/10/202013/10/202014/10/202015/10/202016/10/202017/10/202018/10/202019/10/202020/10/202021/10/2020
6-20.00%20.00%346Metric 119.62%-19.17%-86.29%-70.82%-44.51%-65.48%66.67%-59.60%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%5.95%
7
8>500346Metric 25065015075085015025025026501501501506506501131415
9
10<90.00%346Metric 490.00%90.00%85.00%85.00%85.00%89.00%89.50%89.50%90.00%85.00%85.00%85.00%85.00%85.00%85.00%85.00%85.00%89.00%
Sheet3
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Thank you

seems to be working fab but the last row seems to not work see this example
>15.00%346Metric 44.0%4.0%4.0%4.0%4.0%4.0%4.0%4.0%20.0%20.0%20.0%20.0%
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
20% is not being highlighted and also if the cell value is blank its still highlighting a colour
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,786
Office Version
  1. 365
Platform
  1. Windows
Since post #13 I have been working on these assumptions, (which you have not corrected me on)

It assumes that ..
'Metric 1' always means less than the column B value or greater than the column C value
'Metric 2' always means greater than the column C value
'Metric 4' always means less than the column C value

In the example just given it shows Metric 4 but it appears to have a Metric 2 condition of being greater than the value given in the Variance column
 

mahmed1

Well-known Member
Joined
Mar 28, 2009
Messages
2,188
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
so so so sorry - thats my bad - i should have spotted that
only thing i need to get around is if the value is is blank have no conditional format

14/12/202015/12/202016/12/202017/12/2020
 

Watch MrExcel Video

Forum statistics

Threads
1,112,939
Messages
5,543,119
Members
410,583
Latest member
jgalin
Top