求助大侠写个总表拆分代码

dgseg

由于前两次没有明确需求细节，导致写好的代码不能用，在此感谢要论坛里的热心老师ykcbf1100，多次帮助和指导再次表示感谢。

现在重新整列需求，请老师们给重新写个代码。
需求：
1.表2的数据按业户名称进行拆分，数据填入对应模版预警及处理情况行里，并在风险预警行里统计出各项警情数量

2.拆分时自动新建一个文件夹，把拆分好的文件放入新建的文件夹里，文件按名称按月报表+年月日时间到分钟；拆分后的新表保存PDF格式，表名称按数据年月+按业户名，

3.表4的数据对应业户填入上月对比情况行里，

4.表3的数据统计该业户车辆数量，在线车辆、在线情况等填入上线情况行里
每个表的数据大概有两三千行

wang-way

三个帖子了还没有解决问题？

dgseg

wang-way 发表于 2024-7-13 22:17
三个帖子了还没有解决问题？

没有。                 

dgseg

wang-way 发表于 2024-7-13 22:17
三个帖子了还没有解决问题？

开始需求定位错误，还没解决

3190496160

需求是基本上弄清楚了，但是，这个问题，涉及到增加行，减少行，还有很多项目的累计数量等等，代码量太多，工作量很大，没有几个小时的时间和精力是搞不定的

longwin

工作量有点大，定制可联系qq：55256075

longwin

longwin

附件为生成的PDF文件，没有代码。

liuyu5863016

1. Sub main()
   
2. 
   
3.     Dim source_arr, temp_arr, ws_name_arr
   
4.     Dim cnt%, i%, j%, k%, ws_cnt%, end_row%
   
5.     Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
   
6.    
   
7.     Set ws1 = Worksheets("基础数据源")
   
8.     Set ws2 = Worksheets("加工合同模板")
   
9.    
   
10.    
    
11.     ' 读取数据源
    
12.     end_row = ws1.Range("P66356").End(xlUp).Row
    
13.     source_arr = ws1.Range("A5:P" & end_row)
    
14.    
    
15.     ' 在合同模板中写入基础信息
    
16.     For i = 1 To UBound(source_arr)
    
17.         ' 将合同另存为新sheet，并改名为受托方
    
18.         ws2.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
19.         Set ws3 = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
20.         
    
21.         ' 统计内容的行数
    
22.         cnt = 0
    
23.         For j = i To UBound(source_arr)
    
24.             cnt = cnt + 1
    
25.             If j = end_row - 4 Then
    
26.                 Exit For
    
27.             Else
    
28.                 If Len(source_arr(i + cnt, 2)) Then
    
29.                     Exit For
    
30.                 End If
    
31.             End If
    
32.         Next j
    
33.         
    
34.         With ws3
    
35.             .Cells(2, "L") = source_arr(i, 2)       ' 合同号
    
36.             .Cells(6, "B") = source_arr(i, 5)       ' 受托方
    
37.             .Cells(7, "B") = source_arr(i, 3)       ' 地址
    
38.             .Cells(8, "B") = source_arr(i, 4)       ' 电话
    
39.             
    
40.             ' 判断合同模板的数据行数是否足够
    
41.             If cnt > 20 Then
    
42.                 For j = 1 To cnt - 20
    
43.                     .Rows(32).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
44.                 Next j
    
45.             End If
    
46.             
    
47.             ' 将该合同号下的数据写入temp_arr
    
48.             ReDim temp_arr(1 To cnt, 1 To 11)
    
49.             k = 1
    
50.             Do While k <= cnt
    
51.                 For j = 1 To 11
    
52.                     temp_arr(k, j) = source_arr(i, j + 5)
    
53.                 Next j
    
54.                 i = i + 1
    
55.                 k = k + 1
    
56.             Loop
    
57.             ' 将temp_arr写入合同的数据区域
    
58.             .Cells(13, "A").Resize(UBound(temp_arr, 1), UBound(temp_arr, 2)) = temp_arr
    
59.             
    
60.             ' 修改sheet名
    
61.             ws_cnt = ws_cnt + 1
    
62.             ws3.Name = ws_cnt & "_" & ws3.Cells(6, "B")
    
63.         End With
    
64.         
    
65.         i = i - 1
    
66.         
    
67.     Next i
    
68.    
    
69.    
    
70. End Sub
    

复制代码

liuyu5863016

链接：https://pan.baidu.com/s/1C0UeJRnqkmo6gCMtemEzBg?pwd=6666
提取码：6666
复制这段内容后打开百度网盘手机App，操作更方便哦
文件名：VBA011-分发数据到模板并保存为PDF