分组求第一个和最后一个之间的天数

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, r&
   
    Application.ScreenUpdating = False
   
    ar = [B1].CurrentRegion.Value
    For i = 1 To UBound(ar)
        If ar(i, 2) = "合格" Then
            r = r + 1
            ar(r, 1) = ar(i, 1)
        End If
    Next i
   
    ar = cutArray(ar, 100, , r)
    ReDim br(1 To 2, 1 To UBound(ar)) As String
    For i = 1 To UBound(ar)
        br(1, i) = i
        If UBound(ar(i)) = 100 Then
            br(2, i) = DateValue(ar(i)(1, 1)) - DateValue(ar(i)(100, 1))
        Else
            br(2, i) = UBound(ar(i)) & "%"
        End If
    Next i
        
    [L7].Resize(2, UBound(br, 2)) = br
    Application.ScreenUpdating = True
    Beep
End Sub


Function cutArray(ByVal ar, iCutNum&, Optional ByVal iBeginNum& = 1, _
    Optional ByVal iEndNum& = 0) As Variant()
    Dim br(), cr(), i&, j&, iPosRow&, r&, k&
   
    If iEndNum = 0 Or iEndNum > UBound(ar) Then iEndNum = UBound(ar)
   
    For i = iBeginNum To iEndNum Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > iEndNum, _
        (iEndNum - iBeginNum + 1) Mod iCutNum, iCutNum)
        
        ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
        For j = 1 To UBound(cr)
            For k = 1 To UBound(cr, 2)
                cr(j, k) = ar(i - 1 + j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = cr
    Next i
    cutArray = br
End Function

gwjkkkkk

参与一下。。。