Trying to group numbers in vba-CodePudding

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!

CodePudding user response：

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

CodePudding user response：

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.

Sub Grouping()
'0) get data
    Dim src As Range
    Set src = Sheet1.Range("E1:E59")      ' change to your needs
    Dim data: data = src.Value2             ' get 1-based 2-dim datafield array
'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: ReDim results(1 To UBound(endRows), 1 To 1)
    Dim i As Long
    results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1, 1), 1)
    For i = 2 To UBound(endRows)
        results(i, 1) = _
            "'" & _
            data(endRows(i - 1, 1)   1, 1) & _
            "-" & _
            data(endRows(i, 1), 1)
    Next
'3) write to any target
    With Sheet1.Range("I1")
        .Resize(UBound(results), 1) = results
    End With
End Sub