|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 ykcbf1100 于 2024-7-10 17:25 编辑
全部代码如下：- Sub ykcbf() '//2024.7.10
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("Scripting.Dictionary")
- Set fso = CreateObject("Scripting.FileSystemObject")
- p = ThisWorkbook.Path & ""
- p1 = p & "PDF目录"
- If Not fso.FolderExists(p1) Then fso.CreateFolder p1
- Set sh = ThisWorkbook.Sheets("模版")
- fn = Format(sh.[a2].Value, "yyyy-m")
- With Sheets("Sheet2")
- r = .Cells(Rows.Count, 1).End(3).Row
- c = .UsedRange.Columns.Count
- arr = .[a1].Resize(r, c)
- End With
- For i = 2 To UBound(arr)
- s = arr(i, 1)
- d(s) = ""
- Next
- With Sheets("Sheet3")
- rr = .Cells(Rows.Count, 1).End(3).Row
- cc = .UsedRange.Columns.Count
- zrr = .[a1].Resize(rr, cc)
- End With
- b = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 12, 14, 15, 2)
- bb = [{7,5,10,4,6,11,9,8}]
- For Each k In d.keys
- sh.Copy
- Set wb = ActiveWorkbook
- m = 0
- ReDim brr(1 To r, 1 To 20)
- With wb.Sheets(1)
- .Name = k
- .[a1] = "【" & k & "】动态监控工作台账"
- .DrawingObjects.Delete
- For i = 2 To UBound(arr)
- s = arr(i, 1)
- If s = k Then
- m = m + 1
- brr(m, 1) = m
- brr(m, 2) = arr(i, 2)
- brr(m, 3) = arr(i, 3)
- brr(m, 5) = arr(i, 4)
- brr(m, 7) = arr(i, 5)
- brr(m, 8) = arr(i, 6)
- brr(m, 9) = arr(i, 7)
- brr(m, 10) = arr(i, 8)
- brr(m, 11) = arr(i, 9)
- brr(m, 13) = arr(i, 10)
- brr(m, 15) = arr(i, 11)
- End If
- Next
- If m > 5 Then
- For x = 1 To m - 5
- .Cells(11 + x, 1).EntireRow.Insert
- Next
- End If
- .Cells(10, 1).Resize(m, 15) = brr
- .Cells(10, 1).Resize(IIf(m < 5, 5, m), 15).WrapText = True
- .Rows(10 & ":" & IIf(m < 5, 5, m) + 9).RowHeight = 30
- .Rows("10:10").Copy
- .Rows("11:" & IIf(m < 5, 5, m) + 9).PasteSpecial Paste:=xlPasteFormats
- Application.CutCopyMode = False
- n = 0
- ReDim crr(1 To 100, 1 To 15)
- ReDim l(1 To 10)
- For i = 2 To UBound(zrr)
- If zrr(i, 2) = Empty Then zrr(i, 2) = zrr(i - 1, 2)
- If zrr(i, 14) = Empty Then zrr(i, 14) = zrr(i - 1, 14)
- If zrr(i, 15) = Empty Then zrr(i, 15) = zrr(i - 1, 15)
- If zrr(i, 1) = k Then
- n = n + 1
- crr(n, 1) = n
- For y = 0 To UBound(b)
- crr(n, y + 2) = zrr(i, b(y))
- Next
- l(1) = l(1) + IIf(arr(i, 8) = "设备误报", 1, 0)
- l(2) = l(2) + IIf(arr(i, 8) = "风险属实", 1, 0)
- For j = 1 To UBound(bb)
- If arr(i, 8) = "风险属实" Then
- l(j + 2) = l(j + 2) + zrr(i, bb(j))
- End If
- Next
- End If
- Next
- r1 = .UsedRange.Find("委托车辆属实风险统计及上月同比情况").Row
- If n > 3 Then
- For x = 1 To n - 3
- .Cells(r1 + 2 + x, 1).EntireRow.Insert
- Next
- End If
- .Cells(r1 + 2, 1).Resize(n, 15) = crr
- .Cells(r1 + 2, 1).Resize(IIf(n < 3, 3, n), 15).WrapText = True
- .Rows(r1 + 2 & ":" & r1 + 1 + IIf(n < 3, 3, n)).RowHeight = 30
- .Rows(r1 + 2 & ":" & r1 + 2).Copy
- .Rows(r1 + 3 & ":" & r1 + 1 + IIf(n < 3, 3, n)).PasteSpecial Paste:=xlPasteFormats
- Application.CutCopyMode = False
- r2 = .Columns(2).Find("风险预警").Row
- .Cells(r2, 3) = "当月处置省智能监管系统各类风险预警（" & n & "）宗，经核实，设备误报（" & l(1) & "）宗；属实风险（" & l(2) & "）宗。其中，属实的风险预警中，接打电话（" & l(3) & "）宗，抽烟（" & l(4) & "）宗，玩手机（" & l(5) & "）宗，超速（" & l(6) & "）宗，超时驾驶（" & l(7) & "）宗，未系安全带（" & l(8) & "）宗，双手脱靶（" & l(9) & "）宗，设备遮挡失效（" & l(10) & "）宗"
- .ExportAsFixedFormat Type:=xlTypePDF, Filename:=p1 & fn & k & ".PDF"
- End With
- wb.Close
- Next
- Application.ScreenUpdating = True
- MsgBox "OK！"
- End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-10 11:51
楼主
