Highlight Columns- Highlight count series of max frequency consecutive positive numbers

M

mr_king

New Member
Joined
May 18, 2018
Messages
15
[FONT=&quot]Hello,[/FONT]
[FONT=&quot]I'm Looking for an excel Formula or VBA code to color (highlight or background fill) columns based on the count series of max frequency consecutive positive numbers. It should be left open ended for more data to be added after column P and Lower than row 5.[/FONT]
[FONT=&quot]
79004872-681f-4ded-805e-96431fa4f75b
832dd83d-9b46-4ce6-be95-73a048b48e70
[/FONT]
[FONT=&quot]Rows described:[/FONT]
[FONT=&quot]1. max positive count is 4 highlighted, sum is 17 [/FONT]
[FONT=&quot]2 max positive count is 5 highlighted, sum is 19[/FONT]
[FONT=&quot]3. max positive count is 8 highlighted, sum is 30
4. max positive count is 6 highlighted, sum is 14
5. max positive count is 2 highlighted, sum is 11
[/FONT]
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG18May19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range, sR [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = ActiveSheet.Cells(1).CurrentRegion
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Rows
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn.Cells
        [COLOR="Navy"]If[/COLOR] R.Value > 0 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = R Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, R)
         [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] nRng.Areas
            [COLOR="Navy"]If[/COLOR] Application.Sum(Rr) > oMax [COLOR="Navy"]Then[/COLOR]
             oMax = Application.Sum(Rr)
             [COLOR="Navy"]Set[/COLOR] sR = Rr
            [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]Next[/COLOR] Rr
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not sR [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] sR.Interior.Color = vbYellow
[COLOR="Navy"]Set[/COLOR] nRng = Nothing: [COLOR="Navy"]Set[/COLOR] sR = Nothing: oMax = 0
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
This code is with added range Addresses and sums on sheet2.

Code: 
[COLOR=navy]Sub[/COLOR] MG18May20
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, R [COLOR=navy]As[/COLOR] Range, Rr [COLOR=navy]As[/COLOR] Range, sR [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oMax [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = ActiveSheet.Cells(1).CurrentRegion
ReDim ray(1 To Rng.Count, 1 To 2)
c = 1
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Rows
      [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Dn.Cells
        [COLOR=navy]If[/COLOR] R.Value > 0 [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] nRng = R Else [COLOR=navy]Set[/COLOR] nRng = Union(nRng, R)
         [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] R
[COLOR=navy]
If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
      [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rr [COLOR=navy]In[/COLOR] nRng.Areas
            [COLOR=navy]If[/COLOR] Application.Sum(Rr) > oMax [COLOR=navy]Then[/COLOR]
             oMax = Application.Sum(Rr)
             [COLOR=navy]Set[/COLOR] sR = Rr
            [COLOR=navy]End[/COLOR] If
      [COLOR=navy]Next[/COLOR] Rr
[COLOR=navy]End[/COLOR] If
[COLOR=navy]
If[/COLOR] Not sR [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    sR.Interior.Color = vbYellow
    c = c + 1
    ray(c, 1) = sR.Address: ray(c, 2) = Application.Sum(sR)
    [COLOR=navy]Set[/COLOR] nRng = Nothing: [COLOR=navy]Set[/COLOR] sR = Nothing: oMax = 0
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn

ray(1, 1) = "Address": ray(1, 2) = "Sum of values"
[COLOR=navy]
With[/COLOR] Sheets("sheet2").Range("A1").Resize(c, 2)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Big Thank you :) The code works great.

If I wanted it to start in cell F20 instead of A1, how would I modify the vba to that cell?


Thanks!
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG19May06
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range, Rr [COLOR="Navy"]As[/COLOR] Range, sR [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Lst = Cells("20", Columns.Count).End(xlToLeft).Column - 4
[COLOR="Navy"]Set[/COLOR] Rng = Range("F20", Range("F" & Rows.Count).End(xlUp)).Resize(, Lst)
ReDim ray(1 To Rng.Count, 1 To 2)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Rows
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn.Cells
        [COLOR="Navy"]If[/COLOR] R.Value > 0 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = R Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, R)
         [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rr [COLOR="Navy"]In[/COLOR] nRng.Areas
            [COLOR="Navy"]If[/COLOR] Application.Sum(Rr) > oMax [COLOR="Navy"]Then[/COLOR]
             oMax = Application.Sum(Rr)
             [COLOR="Navy"]Set[/COLOR] sR = Rr
            [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]Next[/COLOR] Rr
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not sR [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    sR.Interior.Color = vbYellow
    c = c + 1
    ray(c, 1) = sR.Address: ray(c, 2) = Application.Sum(sR)
    [COLOR="Navy"]Set[/COLOR] nRng = Nothing: [COLOR="Navy"]Set[/COLOR] sR = Nothing: oMax = 0
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
ray(1, 1) = "Address": ray(1, 2) = "Sum of values"
[COLOR="Navy"]With[/COLOR] Sheets("sheet2").Range("A1").Resize(c, 2)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG thanks for your assistance. I really appreciate it.

I think we are almost there. I noticed an issue with the logic of the vba coding when adding additional numbers, as seen below in the red outlined cells.

The current VBA code is highlighting in yellow- the max subtotal of consecutive positives, instead of the max count of consecutive positives. The red outlined are a few examples of what I'm looking to see applied instead.


9
2qwhtaq.jpg



Row 1: max count consecutive positives is 5, subtotal is 6 (as seen in outlined red)
Row 2: max count consecutive positives is 5, subtotal is 19.
Row 3: max count consecutive positives is 6, subtotal is 29.
Row 4: max count consecutive positives is 6, subtotal is 14. (as seen in outlined red)
Row 5: max count consecutive positives is 3, subtotal is 4. (as seen in outlined red)


Thanks! :)
 
Upvote 0
Try changing code in red:-
Code: 
If Not sR Is Nothing Then
    sR.Interior.Color = vbYellow
    c = c + 1
    Ray(c, 1) = sR.Address: Ray(c, 2) =[B][COLOR=#FF0000] sR.Count            [/COLOR][/B][COLOR=#000000]'Was :[/COLOR]- Application.Sum(sR)
    Set nRng = Nothing: Set sR = Nothing: oMax = 0
End If
Next Dn
Ray(1, 1) = "Address": Ray(1, 2) = "[B][COLOR=#FF0000]Count [/COLOR][/B]of values"
With Sheets("sheet2").Range("A1").Resize(c, 2)
  [B][COLOR=#FF0000]  .Parent.Columns("A:B").ClearContents[/COLOR][/B]
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
End With
 
Upvote 0
Are you sure ????
This is your original date:-

This is your Basic data starting "F20"
-1-2-313580-1-3-1-11120
0111102245600-2491
1115678001578-83
000-4-32-7-460151511
--205600110-470001
<colgroup><col width="68" style="width: 51pt; mso-width-source: userset; mso-width-alt: 2417;" span="16"> <tbody> </tbody>





This is the results From Original Code
Address
 Sum of values
$I$20:$L$20
17
$K$21:$O$21
19
$F$22:$L$22
29
$P$23:$U$23
14
$I$24:$J$24
11

<tbody>
</tbody>

Here is the result from Latest code:-
Address
Count of values
$I$20:$L$20
4
$K$21:$O$21
5
$F$22:$L$22
7
$P$23:$U$23
6
$I$24:$J$24
2

<tbody>
</tbody>
 
Last edited:
Upvote 0
The VBA works correctly with the original data set. However, when adding/changing the data as seen below, it is not functioning to my desired needs.


The below is the results of the VBA code you provided: As you can see in the below rows 20, 23 & 24 the vba is not correctly highlighting the max count of consecutive positives. The count on sheet2 is not either.

2lmp2xh.jpg
[/IMG]


Current Sheet2 output:

Address
Count of values
$I$20:$L$20
4
$K$21:$O$21
5
$P$22:$U$22
6
$F$23:$G$23
2
$I$24:$J$24
2

<tbody>
</tbody>


Current VBA used that you provided:

Code: 
Sub MG19May06()
Dim Rng As Range, Dn As Range, R As Range, Rr As Range, sR As Range, nRng As Range
Dim oMax As Long, c As Long
Dim Lst As Long
Lst = Cells("20", Columns.Count).End(xlToLeft).Column - 4
Set Rng = Range("F20", Range("F" & Rows.Count).End(xlUp)).Resize(, Lst)
ReDim ray(1 To Rng.Count, 1 To 2)
c = 1
For Each Dn In Rng.Rows
      For Each R In Dn.Cells
        If R.Value > 0 Then
            If nRng Is Nothing Then Set nRng = R Else Set nRng = Union(nRng, R)
         End If
Next R
If Not nRng Is Nothing Then
      For Each Rr In nRng.Areas
            If Application.Sum(Rr) > oMax Then
             oMax = Application.Sum(Rr)
             Set sR = Rr
            End If
      Next Rr
End If
If Not sR Is Nothing Then
    sR.Interior.Color = vbYellow
    c = c + 1
    ray(c, 1) = sR.Address: ray(c, 2) = sR.Count            'Was :- Application.Sum(sR)
    Set nRng = Nothing: Set sR = Nothing: oMax = 0
End If
Next Dn
ray(1, 1) = "Address": ray(1, 2) = "Count of values"
With Sheets("sheet2").Range("A1").Resize(c, 2)
    .Parent.Columns("A:B").ClearContents
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
End With
End Sub



**Below are the results that I'm looking to see from the VBA code: Highlighting the max count of consecutive positives for each row (left open ended for more data to be added on rows & columns). The VBA should be able to correctly identifying & highlight the max count based on any figures entered for each row.

Desired output from example data provided:

142yd8x.jpg
[/IMG]


Desired Sheet2 results:
Address
Count of values
$Q$20:$U$20
5
$K$21:$O$21
5
$P$22:$U$22
6
$P$23:$U$23
6
$M$24:$O$24
3

<tbody>
</tbody>






Thanks for your help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

ajjava
  • Question
Procedure to find MAX VALUE in a SPECIFIC pivot table value field, in the case of MULTIPLE pivot table value fields
Replies
0
Views
831
ajjava
ajjava
L
  • Question
Count if consecutive value is repeated 3 times.
Replies
2
Views
908
Fluff
Fluff
A
  • Question
VBA Highlight cell if contains specific text
Replies
4
Views
147
DanteAmor
DanteAmor
M
  • Solved
Count consecutive number with largest value and sum this
2
Replies
16
Views
1K
meohen1992
M
A
  • Question
formula help please: to return MAX number of consecutive 1's in column when the table filtered
Replies
4
Views
559
DanteAmor
DanteAmor

Forum statistics

Threads
1,214,945
Messages
6,122,393
Members
449,081
Latest member
JAMES KECULAH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top