VBA - highlight consecutive

mahmed1 · Oct 18, 2020

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 · Oct 25, 2020

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

Peter_SSs · Oct 26, 2020

mahmed1 said:
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 · Oct 26, 2020

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







Variance		Consecutive Days Low	Consecutive Days Medium	Consecutive Days High	Metric	28/09/2020	29/09/2020	02/10/2020	03/10/2020	05/10/2020	06/10/2020	07/10/2020	08/10/2020	12/10/2020	13/10/2020	14/10/2020	15/10/2020	16/10/2020	17/10/2020	18/10/2020	19/10/2020	20/10/2020	21/10/2020



-20.00%	20.00%	3	4	6	Metric 1	19.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%

>	500	3	4	6	Metric 2	506	501	507	508	501	502	502	502	6	501	501	501	506	506	501	13	14	15





<	90.00%	3	4	6	Metric 4	90.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%










						0	0	0	0	0	1	1	1	0	1	1	1	1	1	1	1	1	1

					Low
					Medium
					High

mahmed1 · Oct 26, 2020

the columns that have no values were actually hidden columns

mahmed1 · Oct 26, 2020

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 · Oct 26, 2020

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

B

C

D

E

F

G

H

I

L

M

O

P

Q

R

V

W

X

Y

Z

AA

AB

AC

AD

AE

5

Variance

Consecutive Days Low

Consecutive Days Medium

Consecutive Days High

Metric

28/09/2020

29/09/2020

2/10/2020

3/10/2020

5/10/2020

6/10/2020

7/10/2020

8/10/2020

12/10/2020

13/10/2020

14/10/2020

15/10/2020

16/10/2020

17/10/2020

18/10/2020

19/10/2020

20/10/2020

21/10/2020

6

-20.00%

20.00%

3

4

6

Metric 1

19.62%

-19.17%

-86.29%

-70.82%

-44.51%

-65.48%

66.67%

-59.60%

5.95%

7

8

>

500

3

4

6

Metric 2

506

501

507

508

501

502

6

501

506

501

13

14

15

9

10

<

90.00%

3

4

6

Metric 4

90.00%

85.00%

89.00%

89.50%

90.00%

85.00%

89.00%

Sheet3

mahmed1 · Oct 26, 2020

Thank you

seems to be working fab but the last row seems to not work see this example



>	15.00%	3	4	6	Metric 4		4.0%	4.0%	4.0%	4.0%	4.0%	4.0%	4.0%	4.0%	20.0%	20.0%	20.0%	20.0%

mahmed1 · Oct 26, 2020

20% is not being highlighted and also if the cell value is blank its still highlighting a colour

Peter_SSs · Oct 26, 2020

Since post #13 I have been working on these assumptions, (which you have not corrected me on)

Peter_SSs said:
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 · Oct 26, 2020

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/2020	15/12/2020	16/12/2020	17/12/2020

VBA - highlight consecutive

mahmed1

Well-known Member

mahmed1

Well-known Member

Excel Facts

Peter_SSs

MrExcel MVP, Moderator

mahmed1

Well-known Member

mahmed1

Well-known Member

mahmed1

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

mahmed1

Well-known Member

mahmed1

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

mahmed1

Well-known Member

Similar threads

Forum statistics

Share this page

VBA - highlight consecutive

Well-known Member

Well-known Member

Excel Facts

MrExcel MVP, Moderator

Well-known Member

Well-known Member

Well-known Member

MrExcel MVP, Moderator

Well-known Member

Well-known Member

MrExcel MVP, Moderator

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock