数据总表按模版拆分

ykcbf1100

dgseg 发表于 2024-7-10 20:20
我们生成的文件比较多，文件的名称给精确到分钟也行

那就这样吧

1、文件名时间精确到秒；2、增加其它项目统计

ykcbf1100

1、文件名时间精确到秒；

2、增加其它项目统计

1. Sub ykcbf()   '//2024.7.10
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set List = CreateObject("System.Collections.ArrayList")
   
8.     p = ThisWorkbook.Path & ""
   
9.     st = [{"在线","1-3天","3天以上"}]
   
10.     rq = Format(Now(), "yyyymmddhhmm")
    
11.     p1 = p & "PDF目录" & rq & ""
    
12.     rq1 = Format(Now(), "yyyy-m")
    
13.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
14.     Set sh = ThisWorkbook.Sheets("模版")
    
15.     With Sheets("Sheet2")
    
16.         r = .Cells(Rows.Count, 1).End(3).Row
    
17.         c = .UsedRange.Columns.Count
    
18.         arr = .[a1].Resize(r, c)
    
19.     End With
    
20.     For i = 2 To UBound(arr)
    
21.         s = arr(i, 1)
    
22.         d(s) = ""
    
23.     Next
    
24.     With Sheets("Sheet3")
    
25.         rr = .Cells(Rows.Count, 1).End(3).Row
    
26.         cc = .UsedRange.Columns.Count
    
27.         zrr = .[a1].Resize(rr, cc)
    
28.     End With
    
29.     b = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 12, 14, 15, 2)
    
30.     bb = [{7,5,10,4,6,11,9,8}]
    
31.     On Error Resume Next
    
32.     For Each k In d.keys
    
33.         sh.Copy
    
34.         Set wb = ActiveWorkbook
    
35.         m = 0
    
36.         ReDim brr(1 To r, 1 To 20)
    
37.         d1.RemoveAll
    
38.         List.Clear
    
39.         With wb.Sheets(1)
    
40.             .Name = k
    
41.             .[a1] = "【" & k & "】动态监控工作台账"
    
42.             .DrawingObjects.Delete
    
43.             For i = 2 To UBound(arr)
    
44.                 s = arr(i, 1)
    
45.                 If s = k Then
    
46.                     s1 = arr(i, 13): s2 = arr(i, 2)
    
47.                     If Not List.Contains(s2) Then List.Add s2
    
48.                     If Not d1.exists(s1) Then Set d1(s1) = CreateObject("Scripting.Dictionary")
    
49.                     d1(s1)(s2) = ""
    
50.                     m = m + 1
    
51.                     brr(m, 1) = m
    
52.                     brr(m, 2) = arr(i, 2)
    
53.                     brr(m, 3) = arr(i, 3)
    
54.                     brr(m, 5) = arr(i, 4)
    
55.                     brr(m, 7) = arr(i, 5)
    
56.                     brr(m, 8) = arr(i, 6)
    
57.                     brr(m, 9) = arr(i, 7)
    
58.                     brr(m, 10) = arr(i, 8)
    
59.                     brr(m, 11) = arr(i, 9)
    
60.                     brr(m, 13) = arr(i, 10)
    
61.                     brr(m, 15) = arr(i, 11)
    
62.                     tmp = ""
    
63.                     If arr(i, 14) = 1 Then
    
64.                         tmp = tmp & "/" & arr(i, 2) & "：" & arr(i, 13) & "一次"
    
65.                     End If
    
66.                 End If
    
67.             Next
    
68.             If m > 5 Then
    
69.                 For x = 1 To m - 5
    
70.                     .Cells(11 + x, 1).EntireRow.Insert
    
71.                 Next
    
72.             End If
    
73.             .[e4] = List.Count
    
74.             .Cells(10, 1).Resize(m, 15) = brr
    
75.             .Cells(10, 1).Resize(IIf(m < 5, 5, m), 15).WrapText = True
    
76.             .Rows(10 & ":" & IIf(m < 5, 5, m) + 9).RowHeight = 30
    
77.             .Rows("10:10").Copy
    
78.             .Rows("11:" & IIf(m < 5, 5, m) + 9).PasteSpecial Paste:=xlPasteFormats
    
79.             Application.CutCopyMode = False
    
80.             n = 0
    
81.             ReDim crr(1 To 100, 1 To 15)
    
82.             ReDim l(1 To 10)
    
83.             Sum = 0
    
84.             For i = 2 To UBound(zrr)
    
85.                 If zrr(i, 2) = Empty Then zrr(i, 2) = zrr(i - 1, 2)
    
86.                 If zrr(i, 14) = Empty Then zrr(i, 14) = zrr(i - 1, 14)
    
87.                 If zrr(i, 15) = Empty Then zrr(i, 15) = zrr(i - 1, 15)
    
88.                 If zrr(i, 1) = k Then
    
89.                     n = n + 1
    
90.                     crr(n, 1) = n
    
91.                     For y = 0 To UBound(b)
    
92.                         crr(n, y + 2) = zrr(i, b(y))
    
93.                     Next
    
94.                     Sum = Sum + crr(n, 12)
    
95.                     l(1) = l(1) + IIf(arr(i, 8) = "设备误报", 1, 0)
    
96.                     l(2) = l(2) + IIf(arr(i, 8) = "风险属实", 1, 0)
    
97.                     For j = 1 To UBound(bb)
    
98.                         If arr(i, 8) = "风险属实" Then
    
99.                             l(j + 2) = l(j + 2) + zrr(i, bb(j))
    
100.                         End If
     
101.                     Next
     
102.                 End If
     
103.             Next
     
104.             r1 = .UsedRange.Find("委托车辆属实风险统计及上月同比情况").Row
     
105.             If n > 3 Then
     
106.                 For x = 1 To n - 3
     
107.                     .Cells(r1 + 2 + x, 1).EntireRow.Insert
     
108.                 Next
     
109.             End If
     
110.             .Cells(r1 + 2, 1).Resize(n, 15) = crr
     
111.             .Cells(r1 + 2, 1).Resize(IIf(n < 3, 3, n), 15).WrapText = True
     
112.             .Rows(r1 + 2 & ":" & r1 + 1 + IIf(n < 3, 3, n)).RowHeight = 30
     
113.             .Rows(r1 + 2 & ":" & r1 + 2).Copy
     
114.             .Rows(r1 + 3 & ":" & r1 + 1 + IIf(n < 3, 3, n)).PasteSpecial Paste:=xlPasteFormats
     
115.             Application.CutCopyMode = False
     
116.             r2 = .Columns(2).Find("风险预警").Row
     
117.             t1 = d1(st(1)).Count: t2 = d1(st(2)).Count: t3 = d1(st(3)).Count
     
118.             .Cells(r2 - 1, 3) = "当月委托监控（" & List.Count & "）辆车辆中，共有（" & t1 & "）辆车当月在线、（" & t2 & "）辆车连续1-3天未上线、（" & t3 & "）辆车连续4-7天以上未上线。"
     
119.             .Cells(r2, 3) = "当月处置省智能监管系统各类风险预警（" & Sum & "）宗，经核实，设备误报（" & l(1) & "）宗；属实风险（" & Sum-l(1) & "）宗。其中，属实的风险预警中，接打电话（" & l(3) & "）宗，抽烟（" & l(4) & "）宗，玩手机（" & l(5) & "）宗，超速（" & l(6) & "）宗，超时驾驶（" & l(7) & "）宗，未系安全带（" & l(8) & "）宗，双手脱靶（" & l(9) & "）宗，设备遮挡失效（" & l(10) & "）宗"
     
120.             .Cells(r2 + 1, 3) = IIf(Mid(tmp, 2) = "", "无", Mid(tmp, 2))
     
121.             r = .Cells(Rows.Count, 1).End(3).Row
     
122.             .Cells(r, 1) = "【" & k & "】安全管理人员签名："
     
123.             .ExportAsFixedFormat Type:=xlTypePDF, Filename:=p1 & rq1 & k & ".PDF"
     
124.         End With
     
125.         wb.Close
     
126.     Next
     
127.     Application.ScreenUpdating = True
     
128.     MsgBox "OK！"
     
129. End Sub
     

复制代码

blackttea1

谢谢分享，很感兴趣。