用VBA做固定合同模板分发

ykcbf1100

优化一下代码，改用一个字典。

ykcbf1100

代码优化，改用一个字典。

1. Sub ykcbf()   '//2024.7.7  总表按模板拆分为多表
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each sht In Sheets
   
6.         If InStr("基础数据源|加工合同模板", sht.Name) = 0 Then sht.Delete
   
7.     Next
   
8.     With Sheets("基础数据源")
   
9.         r = .Cells(Rows.Count, 6).End(3).Row
   
10.         arr = .[a1].Resize(r, 16)
    
11.     End With
    
12.     For i = 5 To UBound(arr)
    
13.         If arr(i, 2) = Empty Then arr(i, 2) = arr(i - 1, 2)
    
14.         s = arr(i, 2)
    
15.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
16.         d(s)(i) = i
    
17.     Next
    
18.     On Error Resume Next
    
19.     For Each k In d.keys
    
20.         Sheets("加工合同模板").Copy After:=Sheets(Sheets.Count)
    
21.         Set sht = Sheets(Sheets.Count)
    
22.         m = 0
    
23.         With sht
    
24.             .[l2] = k
    
25.             ReDim brr(1 To 20, 1 To 20)
    
26.             For Each kk In d(k).keys
    
27.                 m = m + 1
    
28.                 If m = 1 Then
    
29.                     .Name = arr(kk, 5)
    
30.                     .[b6] = arr(kk, 5)
    
31.                     .[b7] = arr(kk, 3)
    
32.                     .[b8] = arr(kk, 4)
    
33.                 End If
    
34.                 For j = 6 To UBound(arr)
    
35.                     brr(m, j - 5) = arr(kk, j)
    
36.                 Next
    
37.             Next
    
38.             .[a13].Resize(20, 11) = brr
    
39.         End With
    
40.     Next
    
41.     Sheets("基础数据源").Activate
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

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

复制代码

chenyun1234

各位老师：其实我自己很想学VBA，但是这么多年了，资料买了不少，VBA还是不会写，每一次只能厚着脸皮寻求您们的帮助，再次感谢您们！

ykcbf1100

chenyun1234 发表于 2024-7-22 12:25
各位老师：其实我自己很想学VBA，但是这么多年了，资料买了不少，VBA还是不会写，每一次只能厚着脸皮寻求您 ...

学VBA是个知识积累的过程，而且，要多动手写代码，在写代码的过程中再去针对性学习相关的知识。多看老师们的代码并努力理解之，这是一个捷径。写代码就是一个解题的过程，思路很重要。

chxw68

练练手。。。