多簿多表里面多个图表，怎么批量导出每个工作表的指定图表到word？

疯泠风

如附件一样，每个Excel有七个工作表，每个工作表有两个图表，其中一个是有红线的，我想把所有工作簿里面所有工作表里的带红线那个图表批量导出到word，然后再在每个工作簿导出的图表后添加文字说明（即每7个图表后添加文字说明），依次排序下去。请问该怎么弄？

疯泠风

有没有大佬帮帮忙啊

疯泠风

这是要沉的节奏么

dyp1610

1. Sub ExportChart()
   
2.     Dim objWord As Object
   
3.     Dim objDoc As Object
   
4.     Dim objSelection As Object
   
5.    
   
6.     Dim MyFile As String
   
7.     Dim s As String
   
8.     Dim count As Integer
   
9.    
   
10.     Set objWord = CreateObject("Word.Application")
    
11.     Set objDoc = objWord.Documents.Add
    
12.     objWord.Visible = True
    
13.     Set objSelection = objWord.Selection
    
14.    
    
15.     MP = "C:\导出模版及原始数据"
    
16.    
    
17. '    MP = ActiveWorkbook.Path
    
18.     MN = Dir(MP & "" & "*.xlsx")
    
19.     AW = ActiveWorkbook.Name
    
20. 
    
21.     Do While MN <> ""
    
22.         If MN <> AW Then
    
23.             Set wb = Workbooks.Open(MP & "" & MN)
    
24.                 For Each sht In Sheets
    
25.                     For Each ocharts In sht.ChartObjects
    
26.                         With ocharts.Chart
    
27.                             For Each serie In .SeriesCollection
    
28.                                 If serie.Border.Color = RGB(255, 0, 0) Then
    
29.                                     .CopyPicture
    
30.                                     objSelection.Paste
    
31.                                 End If
    
32.                             Next
    
33.                         End With
    
34.                     Next
    
35.                 Next
    
36.         End If
    
37.         wb.Close False
    
38.         MN = Dir
    
39.     Loop
    
40.     objDoc.SaveAs ("D:\MyFirstSave")
    
41. End Sub

复制代码

疯泠风

dyp1610 发表于 2020-2-28 14:00

感谢大佬帮忙编程，不过好像导出的word是空白的？并没有导出图片啊

dyp1610

注意修改这句MP = "C:\导出模版及原始数据"，放上你的文件夹的位置

blackttea1

关注下，调整了路径后，我的现象也和5楼一样

疯泠风

dyp1610 发表于 2020-3-2 11:18
注意修改这句MP = "C:\导出模版及原始数据"，放上你的文件夹的位置

修改了路径，出来还是空白文档，不知道咋回事

dyp1610

疯泠风 发表于 2020-3-3 09:25
修改了路径，出来还是空白文档，不知道咋回事

仔细看了一下，代码上传时斜杠丢失了。
    Dim objDoc As Object
    Dim objSelection As Object
   
    Dim MyFile As String
    Dim s As String
    Dim count As Integer
   
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    Set objSelection = objWord.Selection
   
    MP = "C:\导出模版及原始数据"
   
'    MP = ActiveWorkbook.Path
    MN = Dir(MP & "\" & "*.xlsx")
    AW = ActiveWorkbook.Name

    Do While MN <> ""
        If MN <> AW Then
            Set wb = Workbooks.Open(MP & "\" & MN)
                For Each sht In wb.Sheets
                    For Each ocharts In sht.ChartObjects
                        With ocharts.Chart
                            For Each serie In .SeriesCollection
                                If serie.Border.Color = RGB(255, 0, 0) Then
                                    .CopyPicture
                                    objSelection.Paste
                                End If
                            Next
                        End With
                    Next
                Next
        End If
        wb.Close False
        MN = Dir
    Loop
    objDoc.SaveAs ("E:\myfirst.doc")
End Sub

疯泠风

dyp1610 发表于 2020-3-3 12:42
仔细看了一下，代码上传时斜杠丢失了。
    Dim objDoc As Object
    Dim objSelection As Object

非常感谢大神，导出来了，不过在运行的时候，需要一个个打开Excel，而且因为Excel里面有外部链接，每次打开都要选择更新或者不更新，能否不打开Excel，也不弹出更新提示，直接出结果呢？另外导出的word没有文字说明，我一个Excel里面有七个工作表，我想每七个图（也就是一个Excel的图）做个文字说明，就像（图一、图二这样），大神能否改改代码？感激不尽