如何将EXCEL通过宏生成word，求教程

wo971088995

拜托各位大神

小弟需要将excel表中的内容，生成word内容

模板中的word就是最终形式，，，每次都要大量的粘贴复制，求一劳永逸的方法，谢谢大神

小弟必有重谢

wo971088995

忘记上传附件了

这是附件内容

humanmagic

excel记录条数是不是固定数量

xyxcc177

数据表需改善

ydlpc

加油加油加油，期待你的表演。

wo971088995

humanmagic 发表于 2019-12-24 08:40
excel记录条数是不是固定数量

是的  固定数量

wo971088995

xyxcc177 发表于 2019-12-24 08:53
数据表需改善

如何进行改善，请指点

xyxcc177

把照片存放在一个专门的文件夹中，照片字段中记录文件名，有多个照片，用逗号分开

humanmagic

代码放Excel里运行，Excel和Word文件在同一目录，代码运行期间Word不能打开。
漏洞一：Excel文字太长到Word中会显示不全漏洞二：Excel形状不会复制去Word
其它待补充

1. Sub demo()
   
2.     Application.ScreenUpdating = False
   
3.     Dim wordapp As Object, arr, i As Long, j As Long
   
4.     'Word图片位置和宽高,四组
   
5.     Dim t1 As Double, t2 As Double, l1 As Double, l2 As Double
   
6.     Dim w1 As Double, w2 As Double, h1 As Double, h2 As Double
   
7.     Dim t3 As Double, t4 As Double, l3 As Double, l4 As Double
   
8.     Dim w3 As Double, w4 As Double, h3 As Double, h4 As Double
   
9.     l1 = -4.9: t1 = 0.6: h1 = 126.75: w1 = 217.5
   
10.     l2 = -3.9: t2 = 0.6: h2 = 126.75: w2 = 222
    
11.     l3 = -4.9: t3 = 0.75: h3 = 126.75: w3 = 217.5
    
12.     l4 = -3.9: t4 = 0.75: h4 = 126.75: w4 = 222
    
13.     'Excel图片所在单元格判断
    
14.     Dim le1 As Double, le2 As Double, le3 As Double, leMid As Double
    
15.     Dim to1 As Double, to2 As Double, to3 As Double, to4 As Double, toMid As Double
    
16.     leMid = (Range("H7").Left - Range("G7").Left) / 2
    
17.     le1 = Range("G7").Left + leMid: le2 = Range("H7").Left + leMid: le3 = Range("I7").Left + leMid
    
18.     toMid = (Range("G5").Top - Range("G4").Top) / 2
    
19.     to1 = Range("G3").Top + toMid: to2 = Range("G4").Top + toMid: to3 = Range("G5").Top + toMid: to4 = Range("G6").Top + toMid
    
20.     '图片复制到Word的位置
    
21.     Dim tableIndex As Long, cellIndex As Long
    
22.     arr = Range("D3:F7").Value '工作表数据
    
23.     On Error Resume Next
    
24.     Set wordapp = CreateObject("Word.Application")
    
25.     wordapp.Visible = True
    
26.     With wordapp.documents.Open(ActiveWorkbook.Path & "\城市发展组月检查照片报告.docx")
    
27.         j = .Shapes.Count '删除Word所有Shapes
    
28.         For i = j To 1 Step -1
    
29.              .Shapes(i).Delete
    
30.         Next i
    
31.         For i = 1 To UBound(arr)
    
32.             With .tables(i)
    
33.                 .Cell(2, 2).Range.Text = arr(i, 1)
    
34.                 .Cell(3, 2).Range.Text = arr(i, 2)
    
35.                 .Cell(1, 3).Range.Text = arr(i, 3)
    
36.             End With
    
37.         Next i
    
38.         '图片操作
    
39.         For i = 1 To ActiveSheet.Shapes.Count
    
40.             If ActiveSheet.Shapes(i).Type <> 13 Then GoTo continnue
    
41.             ActiveSheet.Shapes(i).Select
    
42.             Selection.Copy
    
43.             Select Case ActiveSheet.Shapes(i).Top
    
44.                 Case Is < to1
    
45.                     tableIndex = 1
    
46.                 Case Is < to2
    
47.                     tableIndex = 2
    
48.                 Case Is < to3
    
49.                     tableIndex = 3
    
50.                 Case Is < to4
    
51.                     tableIndex = 4
    
52.                 Case Is > to4
    
53.                     tableIndex = 5
    
54.             End Select
    
55.             Select Case ActiveSheet.Shapes(i).Left
    
56.                 Case Is < le1
    
57.                     cellIndex = 1
    
58.                 Case Is < le2
    
59.                     cellIndex = 2
    
60.                 Case Is < le3
    
61.                     cellIndex = 3
    
62.                 Case Is > le3
    
63.                     cellIndex = 4
    
64.             End Select
    
65.             Select Case cellIndex
    
66.                 Case 1
    
67.                     .tables(tableIndex).Cell(4, 1).Range.Paste
    
68.                     .InlineShapes(.InlineShapes.Count).ConvertToShape.WrapFormat.Type = 6
    
69.                     With .Shapes(.Shapes.Count)
    
70.                         .LockAspectRatio = False
    
71.                         .Top = t1: .Left = l1: .Height = h1: .Width = w1
    
72.                     End With
    
73.                 Case 2
    
74.                     .tables(tableIndex).Cell(4, 2).Range.Paste
    
75.                     .InlineShapes(.InlineShapes.Count).ConvertToShape.WrapFormat.Type = 6
    
76.                     With .Shapes(.Shapes.Count)
    
77.                         .LockAspectRatio = False
    
78.                         .Top = t2: .Left = l2: .Height = h2: .Width = w2
    
79.                     End With
    
80.                 Case 3
    
81.                     .tables(tableIndex).Cell(5, 1).Range.Paste
    
82.                     .InlineShapes(.InlineShapes.Count).ConvertToShape.WrapFormat.Type = 6
    
83.                     With .Shapes(.Shapes.Count)
    
84.                         .LockAspectRatio = False
    
85.                         .Top = t3: .Left = l3: .Height = h3: .Width = w3
    
86.                     End With
    
87.                 Case 4
    
88.                     .tables(tableIndex).Cell(5, 2).Range.Paste
    
89.                     .InlineShapes(.InlineShapes.Count).ConvertToShape.WrapFormat.Type = 6
    
90.                     With .Shapes(.Shapes.Count)
    
91.                         .LockAspectRatio = False
    
92.                         .Top = t4: .Left = l4: .Height = h4: .Width = w4
    
93.                     End With
    
94.             End Select
    
95. continnue:
    
96.         Next i
    
97.         .Close -1
    
98.     End With
    
99.     wordapp.Quit
    
100.     If Err.Number <> 0 Then Err.Clear
     
101.     On Error GoTo 0
     
102.     Application.ScreenUpdating = True
     
103. End Sub

复制代码

芐雨

做好模版.docx，与Excel文件放在同一个文件夹
Excel表格中图片的单元格设置为无边框
城市发展组.zip (523.74 KB, 下载次数: 371)

2019-12-24 23:23 上传

点击文件名下载附件

1. Sub getWord()
   
2.     Dim myDocPath$, myPath$
   
3.     Dim sht As Worksheet, Wdapp, myDoc
   
4.     Dim i&, j&, x&, y&, n&
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     Set sht = ActiveSheet
   
8.    
   
9.     lrow = sht.Cells(Rows.Count, 1).End(3).Row
   
10.     myPath = ThisWorkbook.Path
    
11.     myDocPath = ThisWorkbook.Path & "" & "模板.docx"
    
12.    
    
13.     If Dir(myDocPath, 16) = Empty Then
    
14.         Direrror = MsgBox("模板不存在！", vbDefaultButton1, "错误！")
    
15.         Exit Sub
    
16.     End If
    
17.    
    
18.    
    
19.     Set Wdapp = CreateObject("Word.Application")
    
20.     With Wdapp
    
21.         .Visible = False
    
22.         .Documents.Open myDocPath    '打开一个word文档
    
23.         Set myDoc = .ActiveDocument
    
24.         .ActiveWindow.Selection.WholeStory '全选
    
25.         .ActiveWindow.Selection.Copy
    
26.         Set newobj = .Documents.Add '新建一个word文档
    
27.     End With
    
28.     myDoc.Close '关闭模板
    
29.    
    
30.     '根据数据多少复制模板表格
    
31.     With newobj
    
32.         For i = 1 To lrow - 2
    
33.             .ActiveWindow.Selection.Paste '粘贴模板表格
    
34.             
    
35.             .ActiveWindow.Selection.EndKey        '光标置于文件尾部
    
36.             If i < lrow - 2 Then .ActiveWindow.Selection.InsertBreak Type:=7 '换页
    
37.         Next
    
38.     End With
    
39.    
    
40.     '遍历表格
    
41.     For i = 3 To lrow
    
42.         With newobj.Tables(i - 2)
    
43.             .Cell(1, 1).Range = "第" & sht.Cells(i, 1).Value & "个点位" '序号
    
44.             .Cell(1, 3).Range = sht.Cells(i, 6).Value  '点位类型
    
45.             .Cell(2, 2).Range = sht.Cells(i, 4).Value  '地址
    
46.             .Cell(3, 2).Range = sht.Cells(i, 5).Value   '问题
    
47.             
    
48.             For j = 7 To 10
    
49.                 sht.Cells(i, j).CopyPicture  '复制图片
    
50.                 x = (j + 1) \ 2
    
51.                 y = (j + 1) Mod 2 + 1
    
52.                 .Cell(x, y).Range.Paste     '粘贴图片
    
53.                 n = n + 1
    
54.                 newobj.InlineShapes(n).LockAspectRatio = msoFalse '图片非锁定
    
55.                 newobj.InlineShapes(n).Height = 126  '设置图片高度
    
56.                 newobj.InlineShapes(n).Width = 217 '单位是像素，设置图片宽度
    
57.             Next
    
58.         End With
    
59.     Next
    
60.    
    
61.    
    
62.     '另存为
    
63.     newobj.SaveAs2 Filename:=ThisWorkbook.Path & "" & "城市发展组月检查照片报告.docx"
    
64.     newobj.Close
    
65.     Wdapp.Quit
    
66.     Set Wdapp = Nothing
    
67.     MsgBox ("已输出到 Word 文件！")
    
68.    
    
69.     Application.ScreenUpdating = True
    
70. End Sub

复制代码