|
|
有一句代码确实有点问题，
Sub test()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim br(), cr()
With Sheets("数据库")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 7 Then MsgBox "数据库为空！": End
ar = .Range("a1:t" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 4)) <> "" Then
d(Trim(ar(i, 4))) = ""
End If
Next i
If (r - 1) / 5 = Int(r - 1) / 5 Then
sl = (r - 1) / 5
Else
sl = Int(r - 1) / 5 + 1
End If
With Sheets("模板")
rs = .Cells(Rows.Count, 3).End(xlUp).Row
If rs >= 17 Then .Rows("17:" & rs).Delete
.Range("B3,C4:C6,H4:H5,B8:I12") = Empty
m = 17
For i = 2 To sl + d.Count
.Rows("1:16").Copy .Cells(m, 1)
m = m + 16
Next i
m = 8
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
If Trim(ar(i, 4)) = k Then
rq = ar(i, 3)
bh = ar(i, 17)
gys = ar(i, 6)
dh = ar(i, 20)
dz = ar(i, 7)
n = n + 1
For j = 10 To 16
br(n, j - 9) = ar(i, j)
Next j
br(n, 8) = ar(i, 18)
End If
Next i
If n <= 5 Then
.Cells(m - 5, 2) = rq
.Cells(m - 4, 3) = bh
.Cells(m - 4, 8) = k
.Cells(m - 3, 3) = gys
.Cells(m - 3, 8) = dh
.Cells(m - 2, 3) = dz
.Cells(m, 2).Resize(n, UBound(br, 2)) = br
m = m + 16
Else
For i = 1 To n Step 5
.Cells(m - 5, 2) = rq
.Cells(m - 4, 3) = bh
.Cells(m - 4, 8) = k
.Cells(m - 3, 3) = gys
.Cells(m - 3, 8) = dh
.Cells(m - 2, 3) = dz
w = m - 1
For s = i To i + 4
w = w + 1
For j = 1 To 8
.Cells(w, j + 1) = br(s, j)
Next j
Next s
m = m + 16
Next i
End If
Next k
ms = .Cells(Rows.Count, 3).End(xlUp).Row
For i = ms To 8 Step -1
If InStr(.Cells(i, 1), "日期") > 0 And Trim(.Cells(i, 2)) <> "" Then
xh = i
Exit For
End If
Next i
If xh <> "" Then .Rows(xh + 14 & ":" & ms).Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
楼主: aifeiqi
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-27 10:46
楼主
