按要求插空行

准提部林

插入固定空行..by.准提部林
1) "考场"必須已排序
2) 每一考场不會超過15人
3) 每30000行寫入一次(可自調)
Sub Test_A1()
Dim Arr, Brr, R&, RowX&, T$, i&, j%, K&, N&, xA As Range
[h:k].ClearContents
Set xA = [h2]: [h1:k1] = [a1:d1].Value
Arr = Range([d1], Cells(Rows.Count, 1).End(3)(2))
R = UBound(Arr) - 1
K = 15:  RowX = 30000
For i = 2 To R
    If N = 0 Then ReDim Brr(1 To RowX, 1 To 4)
    N = N + 1: K = K - 1
    For j = 1 To 4: Brr(N, j) = Arr(i, j): Next
    If Arr(i + 1, 3) <> Arr(i, 3) Then N = N + K: K = 15
    If N = RowX Or i = R Then
       xA.Resize(N, 4) = Brr
       Set xA = xA(N + 1):  N = 0: K = 15
    End If
Next i
End Sub

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, i&, j&, p&, m&, n&, r&
    p = 2
    With [A1].CurrentRegion
        .Interior.ColorIndex = xlNone
        ar = .Resize(.Rows.Count + 1)
        ReDim br(1 To UBound(ar) * 15, 1 To UBound(ar, 2)) As String
        
        r = 1
        For j = 1 To UBound(ar, 2): br(1, j) = ar(1, j): Next
        
        For i = 2 To UBound(ar) - 1
            If ar(i + 1, 3) <> ar(p, 3) Then
                For m = p To i
                    r = r + 1
                    For j = 1 To UBound(ar, 2)
                        br(r, j) = ar(m, j)
                    Next j
                Next m
                r = r + 15 - (i - p + 1)
                p = i + 1
            End If
        Next i
        Columns("H:K").Clear
        [H1].Resize(r, UBound(br, 2)) = br
    End With
End Sub

gwjkkkkk

参与一下。。。

cai2532

这个必须学习。