按要求插空行

shiiki

考场要求15人一个考场不足15人的插空行补足15行，每个考场人数随机但不会超过15人，因为数据量比较大可能会超过10万行希望哪位老师在写代码时考虑运行速度的问题谢谢！

ykcbf1100

没看明白。你这个模拟效果图是不是正确的啊，没看到是按15人排列的。

shiiki

ykcbf1100 发表于 2024-6-24 09:39
没看明白。你这个模拟效果图是不是正确的啊，没看到是按15人排列的。

人数看考场这一列，100001号15人不需要补，100002号7人补8行，100003号10人补5行依次类推

ykcbf1100

shiiki 发表于 2024-6-24 09:55
人数看考场这一列，100001号15人不需要补，100002号7人补8行，100003号10人补5行依次类推

那你这是啥意思，明明超过15人还排进去

shiiki

ykcbf1100 发表于 2024-6-24 09:59
那你这是啥意思，明明超过15人还排进去

你统计一下考场这一列人数有没有超过15

3190496160

Sub 插入行()
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考场信息为空！": End
    ar = .Range("a1:d" & r)
    .UsedRange.Offset(1, 7) = Empty
    For i = 2 To UBound(ar)
        If ar(i, 3) <> "" Then
            If Not d.exists(ar(i, 3)) Then Set d(ar(i, 3)) = CreateObject("scripting.dictionary")
            d(ar(i, 3))(i) = ""
        End If
    Next i
    m = 2
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For Each kk In d(k).keys
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(kk, j)
            Next j
        Next kk
        .Cells(m, 8).Resize(n, UBound(br, 2)) = br
        m = m + 15
    Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

插空行.rar (16.18 KB, 下载次数: 17)

2024-6-24 10:42 上传

点击文件名下载附件

shiiki

3190496160 发表于 2024-6-24 10:43

太感谢了！

wang-way

我来个最简单 不费脑的

1. Public Sub X()
   
2.     Dim wb As Workbook, sht As Worksheet
   
3.     Set wb = Application.ThisWorkbook
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     Set sht = wb.Worksheets(1)
   
6.     With sht
   
7.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         Set Rng = .Range("A1:Z" & eRow)
   
9.         arr = Rng.Value
   
10.         For i = UBound(arr) To LBound(arr) + 1 Step -1
    
11.             Key = arr(i, 3)
    
12.             If Not dic.Exists(Key) Then
    
13.                 dic(Key) = Array(1, i)
    
14.             Else
    
15.                 ar = dic(Key)
    
16.                 ar(0) = ar(0) + 1
    
17.                 dic(Key) = ar
    
18.             End If
    
19.         Next i
    
20.         For Each Key In dic
    
21.             ar = dic(Key)
    
22.             If ar(0) < 15 Then
    
23.                 .Cells(ar(1) + 1, 1).Resize(15 - ar(0), 1).EntireRow.Insert xlShiftDown
    
24.             End If
    
25.         Next
    
26.     End With
    
27. End Sub
    

复制代码