用VBA做固定合同模板分发

chenyun1234

各位老师：

我想做一个合同模板分发，依据基础数据源数据，填充具体的模板

gwjkkkkk

请忽略。。。

gwjkkkkk

。。。。。。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。总表拆分

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

复制代码

chenyun1234

问题一：
ReDim brr(1 To 20, 1 To 20)
如果我基础数据源的某一合同号不止20行，我想在后面的表里一次性全部填充，怎么修改一下

问题二：


第二个合同号与第一个合同号对应的供应商一致，但是第二个合同号对应的工作表名称没修改过来

我想修改确不知道下手

您在帮忙看看，修改一下

gwjkkkkk

chenyun1234 发表于 2024-6-30 10:29
问题一：
ReDim brr(1 To 20, 1 To 20)
如果我基础数据源的某一合同号不止20行，我想在后面的表里一次性 ...

问题一：可以通过判断，数据是否大于20行，如大于拷贝模板后相应地方增加行。
问题二：不能解决，同一工作簿不能存在相同名字的工作表。

chenyun1234

gwjkkkkk 发表于 2024-6-29 18:46
。。。。。。。。

老师，如果不想要工作表标签为：供应商+合同号，只想是供应商，如果有同一供应商，就以供应商+1.....9这样的标记唯一性，咋修改一下

wang-way

chenyun1234 发表于 2024-6-30 10:29
问题一：
ReDim brr(1 To 20, 1 To 20)
如果我基础数据源的某一合同号不止20行，我想在后面的表里一次性 ...

动态插入行

gwjkkkkk

chenyun1234 发表于 2024-6-30 10:41
老师，如果不想要工作表标签为：供应商+合同号，只想是供应商，如果有同一供应商，就以供应商+1.....9这 ...

二个问题都应该解决了，数据未作验证。。。。