求大神做一个EXCEL表根据模板生成多个文件

zjy1990312

为了方便，我发了一个附件，订单列表有自己填写了三个合同的数据，然后根据合同模板自动生成三个对应的Excel格式的合同文件。合同模板里标黄的地方就是和订单列表对应的填写的位置。
目前我只是在一个合同里写了两行内容，我有的时候合同里会录入上百行内容，所以希望大神考虑一下这种情况。

苏小亓

EXCEL必备工具箱有这个功能，免费的。百度搜索EXCEL必备工具箱。

liangdinghu

同感,有现成的，确实可以去用下。！！！！！！！！！！！

zjy1990312

好吧，才发现我的是学生版，那我去下载一个WPS吧

liujialin0o0

把sheet2合同模板中黄色区域内容清除

1. Sub test()
   
2. Application.DisplayAlerts = False
   
3. Application.ScreenUpdating = False
   
4. 
   
5. Sheets(1).Activate
   
6. n = [A1048576].End(3).Row
   
7. Set d = CreateObject("scripting.dictionary")
   
8. For i = 2 To n
   
9.     d(Cells(i, 1).Value) = ""
   
10. Next
    
11. 
    
12. m = d.Count
    
13. 
    
14. For j = 0 To m - 1
    
15.     Sheets(2).Copy
    
16.     ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & d.keys()(j)
    
17.     [M2] = d.keys()(j)
    
18.     k = 0
    
19.     ThisWorkbook.Activate
    
20.     For i = 2 To n
    
21.         If Cells(i, 1) = d.keys()(j) Then
    
22.             
    
23.             Workbooks(d.keys()(j) & ".xlsx").Activate
    
24.             Cells(16 + k, 1) = k + 1
    
25.             [B16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 2)
    
26.             [D16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 3)
    
27.             [E16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 4)
    
28.             [F16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 5)
    
29.             [G16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 6)
    
30.             [I16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 7)
    
31.             [L16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 8)
    
32.             [N16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 9)
    
33.             [O16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 10)
    
34.             [P16].Offset(k, 0) = ThisWorkbook.Sheets(1).Cells(i, 11)
    
35.             
    
36.             k = k + 1
    
37.             ThisWorkbook.Activate
    
38.         End If
    
39.     Next
    
40.     Workbooks(d.keys()(j) & ".xlsx").Activate
    
41.     [A1].Select
    
42.     Workbooks(d.keys()(j) & ".xlsx").Close 1
    
43. Next
    
44. 
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. End Sub

复制代码

cjc209

本身简单 模板有很多合并单元格 使得代码非常长 没有合并单元格本身一句代码搞定的变成10来句 哎

cjc209

liujialin0o0 发表于 2018-11-28 15:41
把sheet2合同模板中黄色区域内容清除

给你小修改了一下代码 你的运行出错 这样就正常运行了

cjc209

Sub test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set r1 = Sheets("订单汇总")
Set r2 = Sheets("合同模板")
n = r1.[A1048576].End(3).Row
Set d = CreateObject("scripting.dictionary")
For i = 2 To n
    d(r1.Cells(i, 1).Value) = ""
Next

m = d.Count

For j = 0 To m - 1
sr = d.keys()(j)
    r2.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & sr
    [M2] = d.keys()(j)
    k = 0
    For i = 2 To n
        If r1.Cells(i, 1) = d.keys()(j) Then
With r1
            Cells(16 + k, 1) = k + 1
            [B16].Offset(k, 0) = .Cells(i, 2)
            [D16].Offset(k, 0) = .Cells(i, 3)
            [E16].Offset(k, 0) = .Cells(i, 4)
            [F16].Offset(k, 0) = .Cells(i, 5)
            [G16].Offset(k, 0) = .Cells(i, 6)
            [I16].Offset(k, 0) = .Cells(i, 7)
            [L16].Offset(k, 0) = .Cells(i, 8)
            [N16].Offset(k, 0) = .Cells(i, 9)
            [O16].Offset(k, 0) = .Cells(i, 10)
            [P16].Offset(k, 0) = .Cells(i, 11)
            
            k = k + 1
      End With
        End If
    Next
    ActiveSheet.Name = sr
    ActiveWorkbook.Close True
   
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

zjy1990312

cjc209 发表于 2018-11-28 18:32
Sub test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

太感谢了，6666

zopey

Sub test()
Dim arr, k1, k2, d2
k1 = [a1].End(4).Row
k2 = [a1].End(2).Column
arr = [a1].Resize(k1, k2)

Set d2 = CreateObject("scripting.dictionary")
For i = 2 To k1
    If Not d2.exists(arr(i, 1)) Then
       d2(arr(i, 1)) = i
    Else
       d2(arr(i, 1)) = d2(arr(i, 1)) & "," & i
    End If
Next

''''''''''''''''''''''''''''''
Dim brr, d
brr = Worksheets("合同模板").[a14].Resize(1, 16)

Set d = CreateObject("scripting.dictionary")
For j = 1 To 16
    If brr(1, j) <> "" Then d(brr(1, j)) = j
Next

'''''''''''''''''''''''''''''''
Dim crr()
For Each element In d2.keys
k = 0
hth = Split(d2(element), ",")
ReDim crr(1 To 8, 1 To 16)

For i = 0 To UBound(hth) 'arr 行号=hth(i)
    k = k + 1
    crr(k, 1) = k
For j = 2 To k2 'arr 列号=j
    crr(k, d(arr(1, j))) = arr(hth(i) / 1, j)
Next j
Next i


With Worksheets("合同模板")
    .[m2] = element
    .[a16].Resize(8, 16) = crr
    .Copy
End With

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\合同号" & element & ".xlsx"
ActiveWorkbook.Close True
Next

End Sub

订单列表 合同模板.rar (20.65 KB, 下载次数: 88)

2018-11-28 20:25 上传

点击文件名下载附件