Trying to group numbers in vba - excel

Question

I'm trying to group a number from E column starting with 1, the result should be like as below:
Column
E I
1 1-52
. 54-56
. 58-59
.
52
54
55
56
58
59
And I start to write like this:
Sub Group_Numbers()
Dim a As Variant, b As Variant
Dim i As Long, k As Long
Range("I1") = Range("E1")
k = 1
a = Range("E1", Range("E" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 2 To UBound(a)
If a(i, 1) <> Val(a(i - 1, 1)) + 1 Then
k = k + 1
b(k, 1) = a(i, 1)
Else
b(k, 1) = Split(b(k, 1), "-")(0) & -a(i, 1)
End If
Next i
Range("I2").Resize(l).Value = b
End Sub
However, it prompts an error 9 subscript out of range. Hope to get help right here.
Thanks a lot!

Answer 1

I would do the following
Option Explicit
Public Sub Example()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Dim Data() As Variant ' read input data into array
Data = ws.Range("E1", "E" & LastRow).Value2
Dim OutData() As Variant ' define output array
ReDim OutData(1 To UBound(Data, 1), 1 To 1) As Variant
Dim iOut As Long
iOut = 1
Dim StartVal As Long
StartVal = Data(1, 1) ' initialize start value of a group
Dim iRow As Long
For iRow = 2 To UBound(Data, 1) ' loop through values
' check if value is previous value +1
If Data(iRow, 1) <> Data(iRow - 1, 1) + 1 Then
' if not write output from StartVal to previos value
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
iOut = iOut + 1
' and set curent value as new group start
StartVal = Data(iRow, 1)
End If
Next iRow
' close last group
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
' write array back to cells
ws.Range("I1").Resize(RowSize:=iOut).NumberFormat = "#" 'format cells as text so `1-2` does not get converted into date.
ws.Range("I1").Resize(RowSize:=iOut).Value2 = OutData
End Sub

Answer 2

Alternative via Excel's Filter() function (vers. MS 365)
Disposing of the new dynamic array features you can profit from a worksheet-related formula evaluation via a tabular filter upon the data range rows compared with the same range shifted by 1 resulting in an array of endRows numbers. This is the base for a results array which joins start and end values.
The following code allows to define a flexible source range, as the evaluation takes care of the actual start row in the indicated data column.
Example call //edited responding to comment
Sub Grouping()
'0) get data
Dim src As Range
Set src = Sheet1.Range("E1:E59") ' change to your needs
Dim data As Variant
If src.Rows.Count > 1 Then ' is the usual case
data = src.Value2 ' get 2-dim datafield array
Else ' a one liner is the exception
ReDim data(1 To 1, 1 To 1) ' create 2-dim by ReDim
data(1, 1) = Application.Index(src, 1, 1)
End If
'1a)prepare formula evaluation of endRows
Dim EndPattern As String
EndPattern = "=LET(data,$,FILTER(ROW(OFFSET(data,1,0))-" & src.Row & ",ABS(OFFSET(data,1,0)-data)>1))"
EndPattern = Replace(EndPattern, "$", src.Address(False, False))
'1b)evaluate formula
Dim endRows: endRows = src.Parent.Evaluate(EndPattern)
'~~~~~~~~~~~~~~
'2) get results
'~~~~~~~~~~~~~~
Dim results: results = getResults(data, endRows) '<< Help function getResults
'3) write to any target
With Sheet1.Range("I1")
.Resize(UBound(results), 1) = results
End With
End Sub
Help function getResults() //added responding to comment
The usual result of an evaluation is a 1-based 2-dim array with two exceptions code has to provide for:
a) non-findings (which would result only in a returned error value),
b) only a single return value (which is a 1-dim array).
Not enough with these exceptions, the tricky comparison of identical endRows blocks - being shifted by 1 row - makes it necessary to check for the actual last row number if not comprised in endRows. - Imo this might have been the commented issue by #TecLao.
Function getResults(ByRef data, ByRef endRows)
'Purpose: combine value ranges
Dim results As Variant
Dim n As Long: n = UBound(data)
'a) no end row returned by shift-formula evaluation
If IsError(endRows) Then ReDim endRows(1 To 1): endRows(1) = n
'b) one end row found
If Application.WorksheetFunction.CountA(endRows) = 1 Then
ReDim results(1 To IIf(endRows(1) < n, 2, 1), 1 To 1)
'write results
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1), 1)
If UBound(results) = 2 Then
results(2, 1) = _
"'" & data(endRows(1) + 1, 1) & _
"-" & _
data(n, 1)
End If
'c) several end rows found
Else
Dim increment As Long
If endRows(UBound(endRows), 1) < n Then increment = 1
'write results
ReDim results(1 To UBound(endRows) + increment, 1 To 1)
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1, 1), 1)
Dim i As Long
For i = 2 To UBound(endRows)
results(i, 1) = _
"'" & _
data(endRows(i - 1, 1) + 1, 1) & _
"-" & _
data(endRows(i, 1), 1)
Next
If increment Then
results(i, 1) = "'" & data(endRows(i - 1, 1) + 1, 1) & "-" & data(n, 1)
End If
End If
'function return
getResults = results
End Function