求助把excel图片和相对应的信息插入到word 文档中

liuym

求助把excel图片和相对应的信息插入到word 文档中。问题在附件里面。谢谢！







                                      请看附件： 问题.zip (123.73 KB, 下载次数: 8)

2017-4-30 23:16 上传

点击文件名下载附件






                                                  

szm5918

光文字的话可以使用word中的“邮件合并”功能，但是这个功能我只会导入数据部分，图片我刚才试了一下没有弄出来，期待大师指导！！！

liuym

期待各位老师的帮助！

雪舞子

excel图片和相对应的信息插入到word 文档中；
word的文档为A4纸横向，每一张放一个图片和一个信息。

1. Sub eTow_XWZ()
   
2.     Dim Wordapp As Object, WordDoc As Object
   
3.     Dim arr, s$, i%
   
4.     arr = Range("a1").CurrentRegion
   
5.     Set Wordapp = CreateObject("Word.Application")
   
6.     Set WordDoc = Wordapp.Documents.Add
   
7.     With WordDoc
   
8.         .PageSetup.Orientation = wdOrientLandscape
   
9.         For i = 2 To UBound(arr)
   
10.             s = Join(Application.Index(arr, i))
    
11.             .Paragraphs(.Paragraphs.Count).Range.Text = s
    
12.             .Content.InsertParagraphAfter
    
13.             Range("b" & i).CopyPicture
    
14.             .Paragraphs(.Paragraphs.Count).Range.Paste
    
15.             .Content.InsertParagraphAfter
    
16.             .Paragraphs(.Paragraphs.Count).Range.Select
    
17.             Wordapp.Selection.InsertBreak Type:=wdPageBreak
    
18.         Next
    
19.         .SaveAs Filename:=ThisWorkbook.Path & "\问题.docx"
    
20.         .Close True
    
21.     End With
    
22. End Sub

复制代码

工作簿.rar (143.53 KB, 下载次数: 17)

2017-5-4 10:08 上传

点击文件名下载附件

liuym

雪舞子 发表于 2017-5-4 09:55
excel图片和相对应的信息插入到word 文档中；
word的文档为A4纸横向，每一张放一个图片和一个信息。

老师您好！出现了下面的情况。



这一句子出现了问题

Wordapp.Selection.InsertBreak Type:=wdPageBreak

雪舞子

liuym 发表于 2017-5-4 21:21
老师您好！出现了下面的情况。

出现什么问题，把问题描述清楚一些。

这句是加入分页符，换到下一页继续写入数据，

我在excel2013测试通过。

换成如下一句再测试一下：
WordApp.Selection.InsertBreak Type:=wdSectionBreakNextPage

liuym

雪舞子 发表于 2017-5-4 22:38
出现什么问题，把问题描述清楚一些。

这句是加入分页符，换到下一页继续写入数据，

老师您好!出现的问题在附件里面。谢谢！








                     请看附件：    出现的问题上报.zip (315.21 KB, 下载次数: 3)

2017-5-6 09:55 上传

点击文件名下载附件

雪舞子

liuym 发表于 2017-5-6 09:55
老师您好!出现的问题在附件里面。谢谢！

原文件是没问题的，也许与你只复制代码有关。
用如下代码替换一下：

1. Sub eTow_XWZ()
   
2.     Dim Wordapp As Object, WordDoc As Object
   
3.     Dim arr, s$, i%
   
4.     arr = Range("a1").CurrentRegion
   
5.     Set Wordapp = CreateObject("Word.Application")
   
6.     Set WordDoc = Wordapp.Documents.Add
   
7.     With WordDoc
   
8.         .PageSetup.Orientation = 1
   
9.         For i = 2 To UBound(arr)
   
10.             s = Join(Application.Index(arr, i))
    
11.             .Paragraphs(.Paragraphs.Count).Range.Text = s
    
12.             .Content.InsertParagraphAfter
    
13.             Range("b" & i).CopyPicture
    
14.             .Paragraphs(.Paragraphs.Count).Range.Paste
    
15.             If i < UBound(arr) Then
    
16.                 .Content.InsertParagraphAfter
    
17.                 .Paragraphs(.Paragraphs.Count).Range.Select
    
18.                 Wordapp.Selection.InsertBreak Type:=7
    
19.             End If
    
20.         Next
    
21.         .SaveAs Filename:=ThisWorkbook.Path & "\问题.docx"
    
22.         .Close True
    
23.     End With
    
24. End Sub

复制代码

liuym

雪舞子 发表于 2017-5-6 11:14
原文件是没问题的，也许与你只复制代码有关。
用如下代码替换一下：

老师您好！试了一下，而且没有达到想要的效果。我想要的是：

序号	名称	规格	单位	数量	定位	定署	备注
2	湖泊	1230	有	14	工作	工作	工作

下面的图片要根据表格的大小而自动调整。


     谢谢！

雪舞子

liuym 发表于 2017-5-6 11:34
老师您好！试了一下，而且没有达到想要的效果。我想要的是：

求助附件中未看到楼主任何示例文件，
代码是根据楼主在excel文件上的文字描述写的，也许没有理解楼主的真正意图，
基本代码有了，楼主需要什么效果可以自己增删一下。