求大神增加VBA实现批量生成合同

光脚踢球

VBA是坛里 @chxw68 写的，非常感谢他的帮忙！现在需要增加条件，希望坛里大神帮忙，在此先谢过！！

如图所示：在EXCEL文件中将O列想对的数据，生成到WORD中的表格里，非常感谢！数据量很多~~



合同生成文件.rar (32.41 KB, 下载次数: 184)

2016-4-18 08:51 上传

点击文件名下载附件

光脚踢球

求路过的大神看一眼吧

Sub test()
  Dim d As Object
  Dim wordapp As Object
  Dim mydoc As Word.Document
  Dim mytab As Word.Table
  Dim i%, j%
  Dim mypath$, myname$
  Dim arr, brr, crr(), vs
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set d = CreateObject("scripting.dictionary")
  Set wordapp = CreateObject("word.application")
  vs = Array(0, 1, 2, 3, 5, 6, 7, 8)
  mypath = ThisWorkbook.Path & "\"
  If Dir(mypath & "农村土地家庭承包合同.doc") = "" Then
    MsgBox mypath & "农村土地家庭承包合同.doc不存在!"
    Exit Sub
  End If
  Set mydoc = wordapp.Documents.Open(mypath & "农村土地家庭承包合同.doc")
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 4).End(xlUp).Row
    arr = .Range("a3:l" & r)
    For i = 1 To UBound(arr)
      If Left(arr(i, 6), 1) = "." Then
          arr(i, 6) = "0" & arr(i, 6)
      End If
      If Len(arr(i, 1)) <> 0 Then
        xm = arr(i, 1)
        Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
        d(arr(i, 1))("权利人") = arr(i, 2)
        d(arr(i, 1))("宗地数") = arr(i, 3)
        d(arr(i, 1))("面积") = arr(i, 11)
        d(arr(i, 1))("合同编码") = arr(i, 12)
      End If
      If Not d(xm).Exists("地块") Then
        m = 1
        ReDim brr(1 To 7, 1 To m)
      Else
        brr = d(xm)("地块")
        m = UBound(brr, 2) + 1
        ReDim Preserve brr(1 To 7, 1 To m)
      End If
      For j = 1 To 7
        brr(j, m) = arr(i, j + 3)

      Next
      d(xm)("地块") = brr
    Next
  End With
  With Worksheets("sheet2")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:e" & r)
    For i = 1 To UBound(arr)
      If d.Exists(arr(i, 1)) Then
        If Not d(arr(i, 1)).Exists("家庭") Then
          m = 1
          ReDim brr(1 To 4, 1 To m)
        Else
          brr = d(arr(i, 1))("家庭")
          m = UBound(brr, 2) + 1
          ReDim Preserve brr(1 To 4, 1 To m)
        End If
        For j = 1 To 4
          brr(j, m) = arr(i, j + 1)
        Next
        d(arr(i, 1))("家庭") = brr
      End If
    Next
  End With
  For Each aa In d.Keys
    For Each ss In Array("地块", "家庭")
      If d(aa).Exists(ss) Then
        brr = d(aa)(ss)
        ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
        For i = 1 To UBound(brr)
          For j = 1 To UBound(brr, 2)
            crr(j, i) = brr(i, j)
          Next
        Next
        d(aa)(ss) = crr
      End If
    Next
  Next
  kk = d(1).Keys
  tt = d(1).Items
  With mydoc
    For Each aa In d.Keys
      .Fields(1).Result.Text = d(aa)("合同编码")
      .Fields(2).Result.Text = d(aa)("权利人")
      .Fields(3).Result.Text = UBound(d(aa)("家庭"))
      .Fields(4).Result.Text = d(aa)("宗地数")
      .Fields(5).Result.Text = d(aa)("面积")
      For j = 1 To 5
        .Fields(j).ShowCodes = False
      Next
      
      With .Tables(1)
        For i = 2 To .Rows.Count
          For j = 1 To .Columns.Count
            .Cell(i, j).Range.Text = ""
          Next
        Next
        If d(aa).Exists("家庭") Then
          brr = d(aa)("家庭")
          m = 2
          n = 1
          For i = 1 To Application.Min(UBound(brr), 15)   '合同家庭共有人人数
            .Cell(m, n).Range.Text = brr(i, 1)
            .Cell(m, n + 1).Range.Text = brr(i, 3)
            .Cell(m, n + 2).Range.Text = brr(i, 4)
            m = m + 1
            If m = 7 Then '合同家庭共有人表格行数
              m = 2
              n = n + 3
            End If
          Next
        End If
      End With
      
      With .Tables(2)
        For i = 3 To .Rows.Count
          For j = 1 To .Columns.Count
            .Cell(i, j).Range.Text = ""
          Next
        Next
        If d(aa).Exists("地块") Then
          brr = d(aa)("地块")
          For i = 1 To Application.Min(UBound(brr), 100)
            For k = 1 To UBound(vs)
              .Cell(i + 2, vs(k)).Range.Text = brr(i, k)
            Next
          Next
        End If
      End With
      .SaveAs Filename:=mypath & aa & "_" & d(aa)("权利人") & ".doc"
    Next
  End With
  mydoc.Close False
  wordapp.Quit
End Sub


求路过的大神看一眼吧

Moneky

光脚踢球 发表于 2016-4-19 09:55
求路过的大神看一眼吧

Sub test()

将代码改成下面这样。你可以直接复制粘贴去替换就可。

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim wordapp As Object
   
4.     Dim mydoc As Word.Document
   
5.     Dim mytab As Word.Table
   
6.     Dim i%, j%
   
7.     Dim mypath$, myname$
   
8.     Dim arr, brr, crr(), vs
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     Set wordapp = CreateObject("word.application")
    
13.     vs = Array(0, 1, 2, 3, 5, 6, 7, 8, 9)
    
14.     mypath = ThisWorkbook.Path & ""
    
15.     If Dir(mypath & "农村土地家庭承包合同.doc") = "" Then
    
16.         MsgBox mypath & "农村土地家庭承包合同.doc不存在!"
    
17.         Exit Sub
    
18.     End If
    
19.     Set mydoc = wordapp.Documents.Open(mypath & "农村土地家庭承包合同.doc")
    
20.     With Worksheets("sheet1")
    
21.         r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
22.         arr = .Range("a3:o" & r)
    
23.         For i = 1 To UBound(arr)
    
24.             If Left(arr(i, 6), 1) = "." Then
    
25.                 arr(i, 6) = "0" & arr(i, 6)
    
26.             End If
    
27.             If Len(arr(i, 1)) <> 0 Then
    
28.                 xm = arr(i, 1)
    
29.                 Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
30.                 d(arr(i, 1))("权利人") = arr(i, 2)
    
31.                 d(arr(i, 1))("宗地数") = arr(i, 3)
    
32.                 d(arr(i, 1))("面积") = arr(i, 11)
    
33.                 d(arr(i, 1))("合同编码") = arr(i, 12)
    
34.             End If
    
35.             If Not d(xm).Exists("地块") Then
    
36.                 m = 1
    
37.                 ReDim brr(1 To 8, 1 To m)
    
38.             Else
    
39.                 brr = d(xm)("地块")
    
40.                 m = UBound(brr, 2) + 1
    
41.                 ReDim Preserve brr(1 To 8, 1 To m)
    
42.             End If
    
43.             For j = 1 To 8
    
44.                 If j <> 8 Then
    
45.                     brr(j, m) = arr(i, j + 3)
    
46.                 Else
    
47.                     brr(j, m) = arr(i, 15)
    
48.                 End If
    
49.             Next
    
50.             d(xm)("地块") = brr
    
51.         Next
    
52.     End With
    
53.     With Worksheets("sheet2")
    
54.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
55.         arr = .Range("a2:e" & r)
    
56.         For i = 1 To UBound(arr)
    
57.             If d.Exists(arr(i, 1)) Then
    
58.                 If Not d(arr(i, 1)).Exists("家庭") Then
    
59.                     m = 1
    
60.                     ReDim brr(1 To 4, 1 To m)
    
61.                 Else
    
62.                     brr = d(arr(i, 1))("家庭")
    
63.                     m = UBound(brr, 2) + 1
    
64.                     ReDim Preserve brr(1 To 4, 1 To m)
    
65.                 End If
    
66.                 For j = 1 To 4
    
67.                     brr(j, m) = arr(i, j + 1)
    
68.                 Next
    
69.                 d(arr(i, 1))("家庭") = brr
    
70.             End If
    
71.         Next
    
72.     End With
    
73.     For Each aa In d.Keys
    
74.         For Each ss In Array("地块", "家庭")
    
75.             If d(aa).Exists(ss) Then
    
76.                 brr = d(aa)(ss)
    
77.                 ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
78.                 For i = 1 To UBound(brr)
    
79.                     For j = 1 To UBound(brr, 2)
    
80.                         crr(j, i) = brr(i, j)
    
81.                     Next
    
82.                 Next
    
83.                 d(aa)(ss) = crr
    
84.             End If
    
85.         Next
    
86.     Next
    
87.     kk = d(1).Keys
    
88.     tt = d(1).Items
    
89.     With mydoc
    
90.         For Each aa In d.Keys
    
91.             .Fields(1).Result.Text = d(aa)("合同编码")
    
92.             .Fields(2).Result.Text = d(aa)("权利人")
    
93.             .Fields(3).Result.Text = UBound(d(aa)("家庭"))
    
94.             .Fields(4).Result.Text = d(aa)("宗地数")
    
95.             .Fields(5).Result.Text = d(aa)("面积")
    
96.             For j = 1 To 5
    
97.                 .Fields(j).ShowCodes = False
    
98.             Next
    
99.             With .Tables(1)
    
100.                 For i = 2 To .Rows.Count
     
101.                     For j = 1 To .Columns.Count
     
102.                         .Cell(i, j).Range.Text = ""
     
103.                     Next
     
104.                 Next
     
105.                 If d(aa).Exists("家庭") Then
     
106.                     brr = d(aa)("家庭")
     
107.                     m = 2
     
108.                     n = 1
     
109.                     For i = 1 To Application.Min(UBound(brr), 15)   '合同家庭共有人人数
     
110.                         .Cell(m, n).Range.Text = brr(i, 1)
     
111.                         .Cell(m, n + 1).Range.Text = brr(i, 3)
     
112.                         .Cell(m, n + 2).Range.Text = brr(i, 4)
     
113.                         m = m + 1
     
114.                         If m = 7 Then '合同家庭共有人表格行数
     
115.                             m = 2
     
116.                             n = n + 3
     
117.                         End If
     
118.                     Next
     
119.                 End If
     
120.             End With
     
121.             With .Tables(2)
     
122.                 For i = 3 To .Rows.Count
     
123.                     For j = 1 To .Columns.Count
     
124.                         .Cell(i, j).Range.Text = ""
     
125.                     Next
     
126.                 Next
     
127.                 If d(aa).Exists("地块") Then
     
128.                     brr = d(aa)("地块")
     
129.                     For i = 1 To Application.Min(UBound(brr), 100)
     
130.                         For k = 1 To UBound(vs)
     
131.                             .Cell(i + 2, vs(k)).Range.Text = brr(i, k)
     
132.                         Next
     
133.                     Next
     
134.                 End If
     
135.             End With
     
136.         .SaveAs Filename:=mypath & aa & "_" & d(aa)("权利人") & ".doc"
     
137.         Next
     
138.     End With
     
139.     mydoc.Close False
     
140.     wordapp.Quit
     
141. End Sub
     

复制代码

光脚踢球

Moneky 发表于 2016-4-19 11:15
将代码改成下面这样。你可以直接复制粘贴去替换就可。

实在是太感谢了！先试一下~~~~

光脚踢球

Moneky 发表于 2016-4-19 11:15
将代码改成下面这样。你可以直接复制粘贴去替换就可。

感谢大神上次的修改，已经成功完成生成，但这回又增加一项，我把大神的代码和之前的对比了一下，自己修改增加了，可是不对，实在太难了，希望大神再帮忙增加一项：

1、EXCEL表的P列中的“地力等级”对应提取到WORD中的“承包土地情况”“地力等级”列中。

光脚踢球

@Moneky

合同生成文件_地力.rar (36.04 KB, 下载次数: 87)

2016-6-30 11:05 上传

点击文件名下载附件

Moneky

光脚踢球 发表于 2016-6-30 11:06
@Moneky

将代码改成下面这样

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim wordapp As Object
   
4.     Dim mydoc As Word.Document
   
5.     Dim mytab As Word.Table
   
6.     Dim i%, j%
   
7.     Dim mypath$, myname$
   
8.     Dim arr, brr, crr(), vs
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     Set wordapp = CreateObject("word.application")
    
13.     vs = Array(0, 1, 2, 3, 5, 6, 7, 8, 9, 4)
    
14.     mypath = ThisWorkbook.Path & ""
    
15.     If Dir(mypath & "农村土地家庭承包合同.doc") = "" Then
    
16.         MsgBox mypath & "农村土地家庭承包合同.doc不存在!"
    
17.         Exit Sub
    
18.     End If
    
19.     Set mydoc = wordapp.Documents.Open(mypath & "农村土地家庭承包合同.doc")
    
20.     wordapp.Visible = True
    
21.     With Worksheets("sheet1")
    
22.         r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
23.         arr = .Range("a3:p" & r)
    
24.         For i = 1 To UBound(arr)
    
25.             If Left(arr(i, 6), 1) = "." Then
    
26.                 arr(i, 6) = "0" & arr(i, 6)
    
27.             End If
    
28.             If Len(arr(i, 1)) <> 0 Then
    
29.                 xm = arr(i, 1)
    
30.                 Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
31.                 d(arr(i, 1))("权利人") = arr(i, 2)
    
32.                 d(arr(i, 1))("宗地数") = arr(i, 3)
    
33.                 d(arr(i, 1))("面积") = arr(i, 11)
    
34.                 d(arr(i, 1))("合同编码") = arr(i, 12)
    
35.             End If
    
36.             If Not d(xm).Exists("地块") Then
    
37.                 m = 1
    
38.                 ReDim brr(1 To 9, 1 To m)
    
39.             Else
    
40.                 brr = d(xm)("地块")
    
41.                 m = UBound(brr, 2) + 1
    
42.                 ReDim Preserve brr(1 To 9, 1 To m)
    
43.             End If
    
44.             For j = 1 To 9
    
45.                 If j = 8 Then
    
46.                     brr(j, m) = arr(i, 15)
    
47.                 ElseIf j = 9 Then
    
48.                     brr(j, m) = arr(i, 16)
    
49.                 Else
    
50.                     brr(j, m) = arr(i, j + 3)
    
51.                 End If
    
52.             Next
    
53.             d(xm)("地块") = brr
    
54.         Next
    
55.     End With
    
56.     With Worksheets("sheet2")
    
57.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
58.         arr = .Range("a2:e" & r)
    
59.         For i = 1 To UBound(arr)
    
60.             If d.Exists(arr(i, 1)) Then
    
61.                 If Not d(arr(i, 1)).Exists("家庭") Then
    
62.                     m = 1
    
63.                     ReDim brr(1 To 4, 1 To m)
    
64.                 Else
    
65.                     brr = d(arr(i, 1))("家庭")
    
66.                     m = UBound(brr, 2) + 1
    
67.                     ReDim Preserve brr(1 To 4, 1 To m)
    
68.                 End If
    
69.                 For j = 1 To 4
    
70.                     brr(j, m) = arr(i, j + 1)
    
71.                 Next
    
72.                 d(arr(i, 1))("家庭") = brr
    
73.             End If
    
74.         Next
    
75.     End With
    
76.     For Each aa In d.Keys
    
77.         For Each ss In Array("地块", "家庭")
    
78.             If d(aa).Exists(ss) Then
    
79.                 brr = d(aa)(ss)
    
80.                 ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
81.                 For i = 1 To UBound(brr)
    
82.                     For j = 1 To UBound(brr, 2)
    
83.                         crr(j, i) = brr(i, j)
    
84.                     Next
    
85.                 Next
    
86.                 d(aa)(ss) = crr
    
87.             End If
    
88.         Next
    
89.     Next
    
90.     kk = d(1).Keys
    
91.     tt = d(1).Items
    
92.     With mydoc
    
93.         For Each aa In d.Keys
    
94.             .Fields(1).Result.Text = d(aa)("合同编码")
    
95.             .Fields(2).Result.Text = d(aa)("权利人")
    
96.             .Fields(3).Result.Text = UBound(d(aa)("家庭"))
    
97.             .Fields(4).Result.Text = d(aa)("宗地数")
    
98.             .Fields(5).Result.Text = d(aa)("面积")
    
99.             For j = 1 To 5
    
100.                 .Fields(j).ShowCodes = False
     
101.             Next
     
102.             With .Tables(1)
     
103.                 For i = 2 To .Rows.Count
     
104.                     For j = 1 To .Columns.Count
     
105.                         .Cell(i, j).Range.Text = ""
     
106.                     Next
     
107.                 Next
     
108.                 If d(aa).Exists("家庭") Then
     
109.                     brr = d(aa)("家庭")
     
110.                     m = 2
     
111.                     n = 1
     
112.                     For i = 1 To Application.Min(UBound(brr), 15)   '合同家庭共有人人数
     
113.                         .Cell(m, n).Range.Text = brr(i, 1)
     
114.                         .Cell(m, n + 1).Range.Text = brr(i, 3)
     
115.                         .Cell(m, n + 2).Range.Text = brr(i, 4)
     
116.                         m = m + 1
     
117.                         If m = 7 Then '合同家庭共有人表格行数
     
118.                             m = 2
     
119.                             n = n + 3
     
120.                         End If
     
121.                     Next
     
122.                 End If
     
123.             End With
     
124.             With .Tables(2)
     
125.                 For i = 3 To .Rows.Count
     
126.                     For j = 1 To .Columns.Count
     
127.                         .Cell(i, j).Range.Text = ""
     
128.                     Next
     
129.                 Next
     
130.                 If d(aa).Exists("地块") Then
     
131.                     brr = d(aa)("地块")
     
132.                     For i = 1 To Application.Min(UBound(brr), 100)
     
133.                         For k = 1 To UBound(vs)
     
134.                             .Cell(i + 2, vs(k)).Range.Text = brr(i, k)
     
135.                         Next
     
136.                     Next
     
137.                 End If
     
138.             End With
     
139.         .SaveAs Filename:=mypath & aa & "_" & d(aa)("权利人") & ".doc"
     
140.         Next
     
141.     End With
     
142.     mydoc.Close False
     
143.     wordapp.Quit
     
144. End Sub
     

复制代码

光脚踢球

Moneky 发表于 2016-6-30 13:32
将代码改成下面这样

实在是太感谢了！解决了超级大的问题……

lsc900707

难度不小的excel转word文档的范例，下载学习！

jiminyanyan

这个字典用的还是挺复杂的。。。。