excel多个工作表中折线图批量导出该怎么设置？

lq50504

我有很多个excel文件，文件中有很多工作表，最多的有30个 工作中需要把每个工作表中自动生成的两张折线图按照折线图的标题名称另存为图片，一张一张另存太麻烦了 想请教各位大神有没有更快捷的方法能批量自动按照标题名称把折线图导出来，谢谢大家

爱疯

Sub test()
    Dim p, f
    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & "\"
     If Dir(p & "Pic", vbDirectory) = "" Then MkDir p & "Pic"
    f = Dir(p & "Data\")
    Do While f <> ""
        Call test2(p, f)
        f = Dir
    Loop
End Sub


'某个工作簿
Sub test2(p, f)
    Dim wb, sh, c, str
    Set wb = Workbooks.Open(p & "Data\" & f)
    For Each sh In wb.Sheets
        For Each c In sh.ChartObjects
            str = Split(wb.Name, ".")(0) & "_" & sh.Name & "日_" & c.Index
            str = VBA.Replace(str, "-", "月")
            Call test3(c, p & "Pic\" & str & ".jpg")
        Next c
    Next sh
    wb.Close False
End Sub


'某个图表(对象, 路径)
Sub test3(obj, f)
    obj.CopyPicture Appearance:=xlScreen, Format:=xlBitmap                '将所选对象作为图片复制到剪贴板
    With ActiveSheet.ChartObjects.Add(0, 0, obj.Width, obj.Height).Chart   '创建嵌入式图表
        .Paste                                                          '将剪贴板中的图表数据粘贴到指定的图表中
        .Export Filename:=f                                             '以图形格式导出图表
        .Parent.Delete
    End With
End Sub

1.rar (584.64 KB, 下载次数: 11)

2019-12-5 10:02 上传

点击文件名下载附件

lq50504

爱疯 发表于 2019-12-5 10:02
Sub test()
    Dim p, f
    Application.ScreenUpdating = False

大神 我大概摸索出了你做的这个宏的用法 万分感谢 不过生成的图片文件名称与折线图的标题名称不一致 这个能不能再优化一下

爱疯

lq50504 发表于 2019-12-5 10:27
大神 我大概摸索出了你做的这个宏的用法 万分感谢 不过生成的图片文件名称与折线图的标题名称不一致 这个 ...

不知道图片文件名有怎样的要求，可以具体举个例子吗？

lq50504

导出来的图片你打开看下 上面有标题 每个图片都不一样 例如 03-05温度比对 01-05湿度比对 这种名称

爱疯

图片文件名 = excel文件名 + (转为日期的)工作表名 + 图片索引号

楼主可按自己的需求，改下 变量 str

lq50504

我尝试一下 谢谢大神指导思路

爱疯

2.rar (188.73 KB, 下载次数: 21)

2019-12-5 17:17 上传

点击文件名下载附件

lq50504

膜拜中 太强了

huangliangji

我也遇到这个问题啊，可以请教大师们吗？