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

[mr_king]

[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]

[/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]

 

[MickG]

Try this, I think this will work for you.!!
NB:- If there are more than one set of data with the same count in any line, then the code will highlight the last range in that line.

[COLOR=navy]Sub[/COLOR] MG24May58
[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] Rr.Count >= oMax [COLOR=navy]Then[/COLOR]
             oMax = Rr.Count
             [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) = sR.Count 
    [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) = "Count 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

 

[Marcelo Branco]

Shouldn't the desired output be?

Sheet1

F​

G​

H​

I​

J​

K​

L​

M​

N​

O​

P​

Q​

R​

S​

T​

U​

V​

20​

-1​

-2​

-3​

1​

3​

5​

8​

0​

-1​

-3​

-1​

1​

1​

1​

2​

1​

-2​

21​

0​

1​

1​

11​

0​

2​

2​

4​

5​

6​

0​

0​

-2​

4​

9​

1​

2​

22​

1​

-2​

1​

5​

6​

7​

8​

1​

0​

0​

1​

5​

7​

8​

4​

4​

-1​

23​

4​

25​

0​

-4​

-3​

2​

-7​

-4​

6​

0​

1​

5​

1​

5​

1​

1​

0​

24​

1​

-2​

0​

5​

6​

0​

0​

1​

1​

2​

-4​

7​

0​

0​

0​

1​

10​

<tbody>
</tbody>

Sheet2

	A​	B​
1​	Addresses​	Count of Values​
2​	$Q$20:$U$20​	5​
3​	$K$21:$O$21​	5​
4​	$H$22:$M$22, $P$22:$U$22​	6​
5​	$P$23:$U$23​	6​
6​	$M$24:$O$24​	3​

<tbody>
</tbody>

If so, maybe this macro

Sub aTest()
    Dim rData As Range, rRow As Range, rCell As Range
    Dim MaxConsecPos As Long, rRng As Range, lin As Long
    Dim dic As Object
    
    Set rData = Sheets("Sheet1").Range("F20:V24")
    Set dic = CreateObject("Scripting.Dictionary")
    lin = 1

    For Each rRow In rData.Rows
        lin = lin + 1
        MaxConsecPos = _
            Sheets("Sheet1").Evaluate(Replace("=Max(FREQUENCY(IF(@>0,COLUMN(@)),IF(@<=0,COLUMN(@))))", "@", rRow.Address))
        Sheets("Sheet2").Range("B" & lin) = MaxConsecPos
        For Each rCell In rRow.Cells
            Set rRng = rCell.Resize(, MaxConsecPos)
            If Application.CountIf(rRng, ">0") = MaxConsecPos Then
                rRng.Interior.Color = vbYellow
                dic(rRow.Row) = dic(rRow.Row) & ", " & rRng.Address
            End If
        Next rCell
    Next rRow
    
    With Sheets("Sheet2")
        .Range("A1:B1") = Array("Addresses", "Count of Values")
        .Range("A2").Resize(dic.Count).Value = _
            Application.Substitute(Application.Transpose(dic.items), ", ", "", 1)
        .Columns("A:B").AutoFit
    End With
End Sub

Hope this helps

M.

 

[mr_king]

Works great. Thanks!