Sum, count and highlight max consecutive numbers

Kishan

Well-known Member
Joined
Mar 15, 2011
Messages
1,648
Office Version
  1. 2010
Platform
  1. Windows
Using Excel 2000

Hi,

I have got data in column B
1-I want sum max consecutives in between intersections of "X" and put sum in column C
2-I need count max consecutives in between intersections of "X" and put sum in column D
3-Highlight max consecutives in the column B

Example data..


Book1
ABCDE
1DataSum Max ConsecutiveCount Max Consecutive
21,1,1,1,1,1,1,1,1,1,1,1,1,11414
31,1,1,1,1,1,1,1,1,1,1,2,1,11514
41,1,1,1,X,X,1,1,X,2,1,X,X,144
51,1,1,1,2,1,2,1,2,X,1,2,2,2129
61,1,1,1,2,X,X,X,2,1,2,X,2,X65
71,1,1,1,2,X,X,2,X,2,1,2,X,X65
81,1,1,X,2,1,1,2,1,X,2,1,X,275
91,1,1,2,1,1,2,1,X,2,1,2,X,1108
101,1,1,2,X,X,2,X,2,1,1,1,X,254
111,1,1,2,X,X,2,X,2,1,X,1,1,X54
121,1,X,1,X,1,X,X,X,1,1,2,2,X64
131,1,X,1,X,1,X,X,X,1,X,2,1,253
141,1,X,1,2,2,X,X,2,2,1,X,2,153
151,1,2,1,X,1,1,X,2,X,1,X,X,X54
161,1,2,1,X,X,X,1,X,2,X,2,1,154
171,1,2,1,X,X,X,1,X,2,2,1,2,X74
181,1,2,1,2,1,2,2,2,1,1,1,2,X1913
191,X,X,X,X,X,2,2,X,1,X,2,X,142
201,X,X,2,X,1,X,X,2,2,1,X,2,153
211,X,X,2,X,1,X,X,2,2,2,1,1,2106
221,2,2,X,X,1,X,2,X,2,X,X,2,153
231,2,2,X,X,1,X,2,X,2,2,2,1,185
241,2,2,2,1,1,2,1,1,1,2,1,1,X1813
251,2,2,2,1,2,1,2,1,X,2,1,2,X149
262,X,X,1,1,1,X,1,2,2,X,X,1,253
272,X,X,1,X,1,X,2,1,X,2,1,1,X43
282,X,X,1,X,2,X,2,X,1,1,2,2,X64
29X,1,1,1,1,X,1,1,2,2,2,X,2,285
30X,1,1,1,X,1,2,1,2,X,1,2,1,264
31X,X,2,X,2,X,2,1,2,2,1,2,X,1106
32X,X,2,X,2,2,X,2,1,2,2,1,X,X85
332,X,X,X,2,2,X,2,1,1,X,X,1,243
342,X,X,2,X,X,X,2,1,2,1,2,2,X106
352,X,X,2,X,X,X,2,1,2,X,2,2,153
362,X,X,2,X,2,1,X,1,2,2,2,1,X85
37X,X,1,2,1,2,2,X,X,X,X,X,1,X85
38X,X,1,2,2,1,2,1,2,1,2,2,X,21610
39X,X,X,X,1,1,1,1,2,X,1,2,2,165
40X,X,X,X,X,1,2,2,2,2,1,1,2,1149
41X,X,X,X,X,1,2,2,2,2,X,2,2,X95
42
43
44
Sheet1


Thank you in advance

Regards,
Kishan
 
Last edited:

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
See if this works for you. Highlighted the max consecutive numbers string in red font.
Code:
Sub Kishan()
Dim R As Range, c As Range, V As Variant, Ct As Long
Dim S As Long, i As Long, Smax As Long, Ctmax As Long
Dim Start As Long, Nd As Long, TempStart As Long
Set R = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
For Each c In R
    Start = 1: Nd = 0: Ct = 0: Ctmax = 0: S = 0: Smax = 0: TempStart = 1
    V = Split(c.Value, ",")
    For i = LBound(V) To UBound(V)
        If IsNumeric(V(i)) Then
            S = S + V(i)
            If S > Smax Then Smax = S
            Ct = Ct + 1
            If Ct > Ctmax Then
                Start = TempStart
                Ctmax = Ct
                Nd = 2 * i + 1
            End If
        ElseIf V(i) = "X" Then
            Ct = 0
            S = 0
            TempStart = Start + 2 * i + 2
        End If
    Next i
    c.Offset(0, 1).Value = Smax
    c.Offset(0, 2) = Ctmax
    c.Characters(Start, Nd - Start + 1).Font.Color = vbRed
Next c
Application.ScreenUpdating = True
End Sub
 
Upvote 0
See if this works for you. Highlighted the max consecutive numbers string in red font.
Code:
Sub Kishan()
Dim R As Range, c As Range, V As Variant, Ct As Long
Dim S As Long, i As Long, Smax As Long, Ctmax As Long
Dim Start As Long, Nd As Long, TempStart As Long
Set R = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
For Each c In R
    Start = 1: Nd = 0: Ct = 0: Ctmax = 0: S = 0: Smax = 0: TempStart = 1
    V = Split(c.Value, ",")
    For i = LBound(V) To UBound(V)
        If IsNumeric(V(i)) Then
            S = S + V(i)
            If S > Smax Then Smax = S
            Ct = Ct + 1
            If Ct > Ctmax Then
                Start = TempStart
                Ctmax = Ct
                Nd = 2 * i + 1
            End If
        ElseIf V(i) = "X" Then
            Ct = 0
            S = 0
            TempStart = Start + 2 * i + 2
        End If
    Next i
    c.Offset(0, 1).Value = Smax
    c.Offset(0, 2) = Ctmax
    c.Characters(Start, Nd - Start + 1).Font.Color = vbRed
Next c
Application.ScreenUpdating = True
End Sub
Amazing JoeMo, The code works as treat. Sums, counts and highlights worked Perfectly!!

:pray: Big thank you

Have a good day

Good Luck

Kind Regards,
Kishan :)
 
Upvote 0
Amazing JoeMo, The code works as treat. Sums, counts and highlights worked Perfectly!!

:pray: Big thank you

Have a good day

Good Luck

Kind Regards,
Kishan :)
You are welcome - thanks for the reply.
 
Upvote 0
I made a small change (shown in red below) just in case you have a data cell containig only X's (X,X,X, ...).
Rich (BB code):
Sub Kishan()
Dim R As Range, c As Range, V As Variant, Ct As Long
Dim S As Long, i As Long, Smax As Long, Ctmax As Long
Dim Start As Long, Nd As Long, TempStart As Long
Set R = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
For Each c In R
       Start = 1: Nd = 0: Ct = 0: Ctmax = 0: S = 0: Smax = 0: TempStart = 1
       V = Split(c.Value, ",")
       For i = LBound(V) To UBound(V)
           If IsNumeric(V(i)) Then
               S = S + V(i)
               If S > Smax Then Smax = S
               Ct = Ct + 1
               If Ct > Ctmax Then
                   Start = TempStart
                   Ctmax = Ct
                   Nd = 2 * i + 1
               End If
           ElseIf V(i) = "X" Then
               Ct = 0
               S = 0
               TempStart = Start + 2 * i + 2
           End If
       Next i
       c.Offset(0, 1).Value = Smax
       c.Offset(0, 2) = Ctmax
        If Ctmax > 0 Then c.Characters(Start, Nd - Start + 1).Font.Color = vbRed
Next c
Application.ScreenUpdating = True
End Sub
 
Upvote 0
The code works as treat. Sums, counts and highlights worked Perfectly!!
I am not so sure Joe's code is coloring all of the consecutive sequences correctly. For example, for the table of values you posted in Message #1 , it looks to me like cells B10, B14, B17, B26, B27, B30, B31, B32, B33, B35 and B36 do not color correctly.

Here is my attempt at a macro to do what you want which I believe works correctly...
Code:
[table="width: 500"]
[tr]
	[td]Sub LongestConsecutiveSequence()
  Dim R As Long, MaxLen As Long, V As Variant, Seq As String, CelVal As String
  Application.ScreenUpdating = False
  For R = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    CelVal = Application.Trim(Replace(Replace(Cells(R, "B").Value, ",", ""), "X", " "))
    MaxLen = 0
    For Each V In Split(CelVal)
      If Len(V) >= MaxLen Then
        MaxLen = Len(V)
        Seq = V
      End If
    Next
    Cells(R, "D").Value = MaxLen
    Seq = StrConv(Seq, vbUnicode)
    Cells(R, "C").Value = Evaluate(Replace(Seq, Chr(0), "+") & 0)
    Seq = Replace(Seq, Chr(0), ",")
    Cells(R, "B").Characters(InStrRev(Cells(R, "B").Value & ",", Seq), Len(Seq) - 1).Font.Color = vbRed
  Next
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]
 
Last edited:
Upvote 0
I am not so sure Joe's code is coloring all of the consecutive sequences correctly. For example, for the table of values you posted in Message #1 , it looks to me like cells B10, B14, B17, B26, B27, B30, B31, B32, B33, B35 and B36 do not color correctly.

Here is my attempt at a macro to do what you want which I believe works correctly...
Code:
[table="width: 500"]
[tr]
	[td]Sub LongestConsecutiveSequence()
  Dim R As Long, MaxLen As Long, V As Variant, Seq As String, CelVal As String
  Application.ScreenUpdating = False
  For R = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    CelVal = Application.Trim(Replace(Replace(Cells(R, "B").Value, ",", ""), "X", " "))
    MaxLen = 0
    For Each V In Split(CelVal)
      If Len(V) >= MaxLen Then
        MaxLen = Len(V)
        Seq = V
      End If
    Next
    Cells(R, "D").Value = MaxLen
    Seq = StrConv(Seq, vbUnicode)
    Cells(R, "C").Value = Evaluate(Replace(Seq, Chr(0), "+") & 0)
    Seq = Replace(Seq, Chr(0), ",")
    Cells(R, "B").Characters(InStrRev(Cells(R, "B").Value & ",", Seq), Len(Seq) - 1).Font.Color = vbRed
  Next
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]
I don't know if the above code is entirely correct because you did not tell us which consecutive sequence you wanted when there are two or more sequences of maximum length. I assumed you wanted the last one because that is what sum you took in those few rows where there were two sequences of maximum length... but then I looked closer and in each of those cases, the last sequence had the maximum sum leaving me to wonder what would you want if the first sequence contained the maximum sum. For example, which sequence should be summed and highlighted in the following, the one I highlighted in red or the one I highlighted in purple?

12X22212X11121
 
Last edited:
Upvote 0
I am not so sure Joe's code is coloring all of the consecutive sequences correctly. For example, for the table of values you posted in Message #1 , it looks to me like cells B10, B14, B17, B26, B27, B30, B31, B32, B33, B35 and B36 do not color correctly.

Here is my attempt at a macro to do what you want which I believe works correctly...
Code:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub LongestConsecutiveSequence()
  Dim R As Long, MaxLen As Long, V As Variant, Seq As String, CelVal As String
  Application.ScreenUpdating = False
  For R = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    CelVal = Application.Trim(Replace(Replace(Cells(R, "B").Value, ",", ""), "X", " "))
    MaxLen = 0
    For Each V In Split(CelVal)
      If Len(V) >= MaxLen Then
        MaxLen = Len(V)
        Seq = V
      End If
    Next
    Cells(R, "D").Value = MaxLen
    Seq = StrConv(Seq, vbUnicode)
    Cells(R, "C").Value = Evaluate(Replace(Seq, Chr(0), "+") & 0)
    Seq = Replace(Seq, Chr(0), ",")
    Cells(R, "B").Characters(InStrRev(Cells(R, "B").Value & ",", Seq), Len(Seq) - 1).Font.Color = vbRed
  Next
  Application.ScreenUpdating = True
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]
Hi Rick, the cells you mention "JoeMo" code is not highlighting correctly in the string, where your code is Perfect!! :)

I don't know if the above code is entirely correct because you did not tell us which consecutive sequence you wanted when there are two or more sequences of maximum length. I assumed you wanted the last one because that is what sum you took in those few rows where there were two sequences of maximum length... but then I looked closer and in each of those cases, the last sequence had the maximum sum leaving me to wonder what would you want if the first sequence contained the maximum sum. For example, which sequence should be summed and highlighted in the following, the one I highlighted in red or the one I highlighted in purple?

12X22212X11121
I did not realise these situations till now you observed, as you have looked very closer, I need to check it, what will be the correct for me. I will tell you once I make it clear for myself.

:pray:Big thank you for looking my request closer and pointing out multiply situation could be there.

Kind Regards,
Kishan :)
 
Upvote 0
I don't know if the above code is entirely correct because you did not tell us which consecutive sequence you wanted when there are two or more sequences of maximum length. I assumed you wanted the last one because that is what sum you took in those few rows where there were two sequences of maximum length... but then I looked closer and in each of those cases, the last sequence had the maximum sum leaving me to wonder what would you want if the first sequence contained the maximum sum. For example, which sequence should be summed and highlighted in the following, the one I highlighted in red or the one I highlighted in purple?

12X22212X11121
Hi Rick, looking to your close observation posted in Message #7, open my eyes and gave me following idea....

1- Find sequence contained the maximum sum. (Sum, count and highlight it)
2- If 2 sequences find with same count (sum, count and highlight both)
3- if possible I have data layout in 2 different formats, please could you make "2" macro for both scenarios,

Example senario1


Book1
ABCDEFGH
1DataCount1Count2Sum1Sum2
2X,1,1,1,1,2,1,X,2,1,X,2,X,267
31,2,2,2,2,2,X,2,2,2,2,2,2,X661112
42,1,X,1,1,X,1,2,1,1,X,X,X,145
51,2,1,1,X,X,X,1,1,1,2,1,1,X67
61,2,1,1,2,1,1,1,X,1,1,2,X,2810
7X,1,1,2,1,2,X,2,2,1,X,X,X,X57
81,1,X,1,2,2,X,1,2,1,2,2,X,258
9X,X,1,1,2,2,2,1,2,1,1,2,1,11217
102,X,2,X,X,2,X,1,1,X,1,X,1,X22
11X,1,X,X,1,1,2,1,2,1,1,1,1,21013
12X,1,1,1,1,1,1,1,2,X,2,1,1,289
131,2,2,X,1,2,1,1,2,1,X,1,1,168
14X,1,1,1,2,2,2,X,1,2,X,1,1,169
15X,1,1,1,2,X,X,1,1,X,1,1,1,14454
161,1,2,1,2,2,1,X,2,1,2,1,X,X710
171,X,1,X,1,X,1,X,1,2,2,X,1,235
181,1,X,1,X,2,X,2,1,2,X,1,X,X35
191,1,2,2,1,1,X,X,1,2,X,2,X,168
201,2,2,2,1,X,2,1,2,1,1,1,1,1810
212,1,1,X,X,2,2,1,2,1,1,1,X,2710
221,2,X,1,X,1,X,X,1,X,1,1,X,X223
231,1,1,X,X,1,1,X,1,2,1,X,1,13334
242,2,2,1,1,X,1,1,2,2,1,1,1,1810
25X,2,1,2,1,2,2,X,2,1,2,1,2,166109
262,1,2,1,1,X,2,X,X,X,2,2,1,257
271,X,1,X,X,1,2,2,1,2,1,1,2,X812
281,1,X,1,1,1,2,1,X,1,1,1,1,15555
291,1,X,2,1,1,1,X,1,2,X,2,1,145
302,1,X,1,X,1,1,1,1,2,2,X,2,X68
312,2,2,1,1,2,1,1,1,1,2,X,2,X1116
32X,1,2,1,1,X,1,1,2,1,2,1,1,1810
33X,X,X,1,1,1,2,2,1,1,1,2,2,11115
34X,X,2,X,X,2,X,1,2,2,1,2,2,X610
351,1,1,1,X,1,1,X,2,1,2,1,2,169
36X,1,2,1,2,2,1,2,1,1,2,X,1,11015
37X,X,1,2,2,2,1,1,1,X,2,1,1,X710
382,X,2,1,2,X,X,1,2,2,X,X,X,X3355
392,2,X,X,1,X,1,1,1,1,1,X,1,X55
402,1,X,1,2,2,2,2,2,1,X,2,1,X712
412,1,2,1,1,X,1,1,2,X,1,2,X,157
422,X,2,2,1,1,1,X,1,1,1,1,X,157
431,2,X,2,2,2,1,2,X,1,1,1,2,15596
44
45
46
47
Sheet5-3


Example senario2


Book1
ABCDEFGHIJKLMNOPQRSTUVWX
1
2
3
4
5
6P1P2P3P4P5P6P7P8P9P10P11P12P13P14Count1Count2Sum1Sum2
7X111121X21X2X267
8122222X222222X661112
921X11X1211XXX145
101211XXX111211X67
1112112111X112X2810
12X11212X221XXXX57
1311X122X12122X258
14XX1122212112111217
152X2XX2X11X1X1X22
16X1XX11212111121013
17X11111112X211289
18122X121121X11168
19X111222X12X11169
20X1112XX11X11114454
211121221X2121XX710
221X1X1X1X122X1235
2311X1X2X212X1XX35
24112211XX12X2X168
2512221X21211111810
26211XX2212111X2710
2712X1X1XX1X11XX223
28111XX11X121X113334
2922211X11221111810
30X212122X21212166109
3121211X2XXX221257
321X1XX12212112X812
3311X11121X111115555
3411X2111X12X21145
3521X1X111122X2X68
3622211211112X2X1116
37X1211X11212111810
38XXX111221112211115
39XX2XX2X122122X610
401111X11X21212169
41X1212212112X111015
42XX1222111X211X710
432X212XX122XXXX3355
4422XX1X11111X1X55
4521X1222221X21X712
4621211X112X12X157
472X22111X1111X157
4812X22212X111215596
49
50
51
Sheet5-4


Thank you for all your kind help

Kind Regards,
Kishan
 
Last edited:
Upvote 0
Hi Rick, looking to your close observation posted in Message #7 , open my eyes and gave me following idea....

1- Find sequence contained the maximum sum. (Sum, count and highlight it)
2- If 2 sequences find with same count (sum, count and highlight both)
3- if possible I have data layout in 2 different formats, please could you make "2" macro for both scenarios,

Example senario1

ABCDEFGH
1DataCount1Count2Sum1Sum2
2X,1,1,1,1,2,1,X,2,1,X,2,X,267
31,2,2,2,2,2,X,2,2,2,2,2,2,X661112

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
I changed the layout for your first scenario to make it easier for you to see. First change I made is to only have one Count column since if there are multiple maximum length sequences, they will always be of the same length, so I saw no reason to repeat the number. Second, you are assuming there will only be a maximum of two sequences of the same length, but that is not correct... you structure allows for up to 7 sequences of the same length. For example, consider this possible Column B value...

1,X,2,X,1,X,1,X,2,X,1,X,2,X

The next change to the layout is that I created 7 summation columns and gave each a different color... the color will match the color used to color the font for the sequence matching the summation position. I also made the color of the numbers in each summation column match the color used for the sequence in Column B. All of these changes should make the grid easier for you to use.... hopefully you will agree. Give this macro a try (all you need is Column B, the code will provide the rest).
Code:
[table="width: 500"]
[tr]
	[td]Sub LongestConsecutiveSequence()
  Dim R As Long, X As Long, MaxLen As Long, Last As Long, LastRow As Long
  Dim V As Variant, Colors As Variant
  Dim Sums(1 To 1, 1 To 7) As Variant, Seq(1 To 1, 1 To 7) As String
  Application.ScreenUpdating = False
  Columns("C:J").Clear
  Colors = [{6,6,3,5,10,26,18,46,16}]
  Range("B1:J1").Value = Array("Data", "Count", "Sum1", "Sum2", "Sum3", "Sum4", "Sum5", "Sum6", "Sum7")
  LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Range("C1").BorderAround xlContinuous, xlThick, , vbBlack
  Range("C1").Copy
  Range("C1:J" & LastRow).PasteSpecial xlPasteFormats
  Range("A1").Select
  For X = 2 To 10
    Cells(1, X).Interior.ColorIndex = Colors(X - 1)
    If X > 2 Then
      With Cells(1, X)
        If X > 3 Then .Font.Color = vbWhite
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
      End With
      With Cells(2, X).Resize(LastRow - 1).Font
        If X = 2 Then .Color = vbBlack
        If X > 3 Then .Color = Cells(1, X).Interior.Color
        .Bold = True
      End With
    End If
  Next
  For R = 2 To LastRow
    X = 0
    MaxLen = 0
    Erase Sums
    Erase Seq
    For Each V In Split(Application.Trim(Replace(Replace(Cells(R, "B").Value, ",", ""), "X", " ")))
      If Len(V) > MaxLen Then
        X = 1
        Erase Sums
        Erase Seq
        MaxLen = Len(V)
        Sums(1, X) = Evaluate(Replace(StrConv(V, vbUnicode), Chr(0), "+") & 0)
        Seq(1, X) = V
      ElseIf Len(V) = MaxLen Then
        X = X + 1
        MaxLen = Len(V)
        Sums(1, X) = Evaluate(Replace(StrConv(V, vbUnicode), Chr(0), "+") & 0)
        Seq(1, X) = V
      End If
    Next
    Cells(R, "C").Value = MaxLen
    Cells(R, "D").Resize(, 7) = Sums
    Last = 0
    For X = 1 To 7
      If Len(Seq(1, X)) Then
        Seq(1, X) = Replace(StrConv(Seq(1, X), vbUnicode), Chr(0), ",")
        Cells(R, "B").Characters(InStr(Last + 1, Cells(R, "B").Value & ",", Seq(1, X)), Len(Seq(1, X)) - 1).Font.ColorIndex = Colors(X + 2)
        Last = InStr(Last + 1, Cells(R, "B").Value & ",", Seq(1, X))
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub
[/td]
[/tr]
[/table]

Note: I will look into your second scenario later tonight when I have more time.
 
Upvote 0

Forum statistics

Threads
1,214,641
Messages
6,120,691
Members
448,978
Latest member
rrauni

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