嘗試在vba中對數字進行分組

我正在嘗試將 E 列中的數字從 1 開始分組，結果應如下所示：

Column
E   I
1   1-52
.   54-56
.   58-59
.
52
54
55
56
58
59

我開始這樣寫：

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

但是提示錯誤9下標超出范圍。希望能在這里得到幫助。

非常感謝！

uj5u.com熱心網友回復：

我會做以下

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

uj5u.com熱心網友回復：

通過 Excel 的Filter()功能替代（與 MS 365 相比）

處理新的動態陣列功能，您可以通過表格過濾器對資料范圍行進行與作業表相關的公式評估，并與相同范圍移動 1 產生endRows數字陣列進行比較。這是results連接開始值和結束值的陣列的基礎。

以下代碼允許定義靈活的源范圍，因為評估負責指定資料列中的實際起始行。

示例呼叫 //編輯回復評論

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

幫助功能getResults() //增加回復評論

評估的通常結果是一個基于 1 的 2-dim 陣列，代碼必須提供兩個例外：

• a) 非發現（只會導致回傳錯誤值），
• b) 只有一個回傳值（它是一個一維陣列）。

除了這些例外還不夠，相同endRows塊的棘手比較- 移動 1 行 - 如果不包含在endRows. - Imo 這可能是@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

標籤：擅长 vba

上一篇：檢測具有特定值的單元格的變化

下一篇：從excel范圍Selenium添加元素