execl数据图表批量填入word

xiachuan980

各位大佬下午好：

     因为实验的原因，需要在execl里分析数据后，批量填入word模板，邮件合并只能填入文字，不能填入数据表和图，请问这种怎么操作，谢谢各位大佬。

约定的童话

非常冷门的需求啊....

3190496160

约定的童话 发表于 2022-11-23 19:38
非常冷门的需求啊....

老兄，分享一下代码呗，特别是插入图表的代码，很想学习学习

aecn

从文件夹插入Word了解过，直接从Excel插入还没接触过

3190496160

Sub 生成word()
Application.ScreenUpdating = False
    Dim i%, ar, myPath$, wdApp, wdD
    myPath = ThisWorkbook.Path & "\"
    Call daochutubiao
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = True
    t = Timer
    With Sheets("sheet1")
        r = .Cells(Rows.Count, 2).End(xlUp).Row
        ar = .Range("b7:e" & r)
        rr = Array(.[b2], .[b3])
    End With
    Set wdD = wdApp.Documents.Open(myPath & "模板.doc")
    With wdD.Tables(1)
        hs = UBound(ar)
        If hs > 15 Then
            ys = hs - 15
            For i = 1 To ys
                Set oRow = .Rows(2)
                '在第2行前面插入行
                .Rows.Add oRow
            Next i
        End If
        For i = 1 To UBound(ar)
            For j = 1 To 4
                .Cell(i, j).Range.Text = ar(i, j)
            Next j
        Next i
    End With
    Set mt = wdD.Tables(2)
    tp = Format(Date, "yyyymmdd") & ".jpg"
    Set oSP = mt.Cell(1, 1).Range.InlineShapes.AddPicture(Filename:=ThisWorkbook.Path & "\" & tp, LinkToFile:=False, SaveWithDocument:=True)
    oSP.Width = mt.Cell(1, 1).Width
    oSP.Height = mt.Cell(1, 1).Height
    For j = 1 To 2
        wdApp.Selection.HomeKey unit:=6 '光标置于文件首
        If wdApp.Selection.Find.Execute("数据" & j) Then '查找到指定字符串
            wdApp.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
            wdApp.Selection.Text = rr(j - 1) '替换字符串
        End If
    Next j
    wdD.SaveAs Filename:=myPath & "实验数据" & Format(Date, "yyyymmdd") & ".doc"
    'wdD.Close
    wdApp.Quit
    Set wdD = Nothing
    Set wdApp = Nothing
Application.ScreenUpdating = False
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒！"
End Sub

3190496160

Sub daochutubiao()
    Dim oShape As Shape
    Dim oChartObject As ChartObject
    Dim oChart As Chart
    Dim oWK As Worksheet
    Dim sPath As String
    Dim i As Long
    Const msoChart = 3
    i = Format(Date, "yyyymmdd")
    sPath = Excel.ThisWorkbook.Path & "\"
    For Each oWK In Excel.ThisWorkbook.Worksheets
        With oWK
            For Each oShape In .Shapes
                With oShape
                     '遍历所有图形对象，如果不是图表类型的，则转换为图表类型的
                    If .Type <> msoChart Then
                        .Copy
                        Set oChartObject = oWK.ChartObjects.Add(0, 0, .Width, .Height)
                        With oChartObject
                            .Chart.Paste
                        End With
                    End If
                End With
            Next
            For Each oChartObject In .ChartObjects
                 With oChartObject
                    .Chart.Export sPath & i & ".jpg"
                    'i = i + 1
                 End With
            Next
        End With
    Next
    For Each oChart In Excel.ThisWorkbook.Charts
        With oChart
            .Export sPath & i & ".bmp"
            'i = i + 1
        End With
    Next
    'MsgBox "所有图表导出完毕!!!"
End Sub

3190496160

实验记录.rar (33.89 KB, 下载次数: 23)

2022-11-24 11:45 上传

点击文件名下载附件

3190496160

方法是笨了点，能够实现所需要的效果，可能一些细节上不一定符合楼主的要求，先看看吧，有问题再说吧

xiachuan980

3190496160 发表于 2022-11-24 11:46
方法是笨了点，能够实现所需要的效果，可能一些细节上不一定符合楼主的要求，先看看吧，有问题再说吧

感谢大大的回复，我在测试的时候，怎么图标导出来没有对呢，是什么原因？

xiachuan980

约定的童话 发表于 2022-11-23 19:38
非常冷门的需求啊....

老大，可以共享一下吗？谢谢