Refine VBA code to summarise by max values

[Peter1986]

Hello there!

I have an existing code which creates a summary table from a dataset by counting the number of repeated consecutive values. If there is a new value in the dataset then a new row is created for it in the summary table.

Please can you advise if it’s possible to edit this macro (or otherwise re-write it) so that it counts all the positive consecutive values (whether they are the same or not) and then adds this to the results table noting down the MAX value in the set. I have included an image below to clarify what I am trying to achieve (existing output in black, required output in red).

This macro will ultimately be used to sort a very large dataset. Any help is very much appreciated!

The existing code is as follows (however I am happy to replace this if there is a better method):

Sub Summarise_Data()

Dim sht As Worksheet, rngSource As Range, rngDest As Range
Dim arrNumbers(3) As Double

Set sht = Worksheets("Sheet1")

Set rngSource = sht.Range("A3")

Set rngDest = sht.Range("E3:H3")

arrNumbers(0) = rngSource.Value
arrNumbers(1) = rngSource.Value
arrNumbers(2) = rngSource.Offset(0, 1).Value
arrNumbers(3) = 1

Set rngSource = rngSource.Offset(1, 0)

Do Until rngSource.Value = ""

    If rngSource.Offset(0, 1).Value <> arrNumbers(2) Then
rngDest.Value = arrNumbers
Set rngDest = rngDest.Offset(1, 0)


arrNumbers(0) = rngSource.Value
arrNumbers(1) = rngSource.Value
arrNumbers(2) = rngSource.Offset(0, 1).Value
arrNumbers(3) = 1

Else

arrNumbers(1) = rngSource.Value
arrNumbers(3) = arrNumbers(3) + 1


End If

Set rngSource = rngSource.Offset(1, 0)
Loop

rngDest.Value = arrNumbers

End Sub

 

[Akuini]

Try this:

Sub a1122767a()
'https://www.mrexcel.com/board/threads/refine-vba-code-to-summarise-by-max-values.1122754/
Dim i As Long, j As Long, k As Long, n As Long
Dim va, vb, vc

n = Range("A" & Rows.Count).End(xlUp).Row
va = Range("B1:B" & n)
vb = Range("A1:B" & n)
ReDim vc(1 To n, 1 To 4)

For i = 1 To n
    If va(i, 1) <> 0 Then va(i, 1) = 1
Next

For i = 3 To UBound(va, 1)
j = i
    Do
        i = i + 1
        If i > UBound(va, 1) Then Exit Do
    Loop While va(i, 1) = va(i - 1, 1)
       
        i = i - 1
        k = k + 1
        vc(k, 1) = vb(j, 1)
        vc(k, 2) = vb(i, 1)
        vc(k, 3) = WorksheetFunction.Max(Cells(j, "B"), Cells(i, "B"))
        vc(k, 4) = i - j + 1

Next

Range("E3").Resize(k, 4) = vc

End Sub

Book1
	A	B	C	D	E	F	G	H
1
2
3	1	0			1	3	0	3
4	2	0			4	7	5	4
5	3	0			8	10	0	3
6	4	1			11	12	7	2
7	5	2			13	13	0	1
8	6	1			14	15	3	2
9	7	5
10	8	0
11	9	0
12	10	0
13	11	1
14	12	7
15	13	0
16	14	3
17	15	3
Sheet1

 

[Peter1986]

Try this:

Sub a1122767a()
'https://www.mrexcel.com/board/threads/refine-vba-code-to-summarise-by-max-values.1122754/
Dim i As Long, j As Long, k As Long, n As Long
Dim va, vb, vc

n = Range("A" & Rows.Count).End(xlUp).Row
va = Range("B1:B" & n)
vb = Range("A1:B" & n)
ReDim vc(1 To n, 1 To 4)

For i = 1 To n
    If va(i, 1) <> 0 Then va(i, 1) = 1
Next

For i = 3 To UBound(va, 1)
j = i
    Do
        i = i + 1
        If i > UBound(va, 1) Then Exit Do
    Loop While va(i, 1) = va(i - 1, 1)
      
        i = i - 1
        k = k + 1
        vc(k, 1) = vb(j, 1)
        vc(k, 2) = vb(i, 1)
        vc(k, 3) = WorksheetFunction.Max(Cells(j, "B"), Cells(i, "B"))
        vc(k, 4) = i - j + 1

Next

Range("E3").Resize(k, 4) = vc

End Sub

Book1
	A	B	C	D	E	F	G	H
1
2
3	1	0			1	3	0	3
4	2	0			4	7	5	4
5	3	0			8	10	0	3
6	4	1			11	12	7	2
7	5	2			13	13	0	1
8	6	1			14	15	3	2
9	7	5
10	8	0
11	9	0
12	10	0
13	11	1
14	12	7
15	13	0
16	14	3
17	15	3
Sheet1

Akuini,

Thank you once again this code works very efficiently.

Note I have made one minor edit changing the following:
vc(k, 3) = WorksheetFunction.Max(Cells(j, "B"), Cells(i, "B"))
to:
Set myRange = Range((Cells(j, "B")), (Cells(i, "B")))
vc(k, 3) = WorksheetFunction.Max(myRange)

so we capture the max of the range rather than the max of the first and last entry.

Thank you!

 

[Akuini]

Ah, sorry my mistake.
Glad you figured it out. A simpler one is:
vc(k, 3) = WorksheetFunction.Max(Range(Cells(j, "B"), Cells(i, "B")))