如何用VBA复制图表到指定位置，并粘贴为JPG

753227299

如图，现在想将“原图栏”B2：C3栏的图表复制到图片栏，并将图片粘贴为JPG图片格式，同时粘贴的位置需要经过鼠标点击，如点击B2，将四张图表复制到B2：C3，如点击B3，则复制到B3：D4。

请求懂的大师指点一下，我试了一下都没弄对，感谢！
求助.rar (10.15 KB, 下载次数: 10)

2019-12-6 16:14 上传

点击文件名下载附件

IVYQQQQQ

附件测试一下吧！

banditson

求助.rar (28.95 KB, 下载次数: 95)

2019-12-6 17:14 上传

点击文件名下载附件

借花献佛，用2楼成果作点修改。

753227299

IVYQQQQQ 发表于 2019-12-6 16:45
附件测试一下吧！

感谢帮助，亲测有效，我昨天忘记说了，因转成的图片还要被其他地方引用，能否把粘贴的图片分开成的呢？不要弄成一张了

753227299

banditson 发表于 2019-12-6 17:16
借花献佛，用2楼成果作点修改。

感谢帮助，亲测有效，我昨天忘记说了，因转成的图片还要被其他地方引用，能否把粘贴的图片分开成的呢？不要弄成一张了，谢谢！

yaozong

753227299 发表于 2019-12-7 10:19
感谢帮助，亲测有效，我昨天忘记说了，因转成的图片还要被其他地方引用，能否把粘贴的图片分开成的呢？不 ...

1. Sub Export2()
   
2.     Sheets("图片").Activate
   
3.     Dim rng As Range, cel As Range, m&, n&
   
4.     For Each cel In Sheets("原图").Range("b2:c3")
   
5.         cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
6.         Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
   
7.         rng.Select
   
8.         ActiveSheet.Paste
   
9.     Next
   
10. End Sub

复制代码

753227299

yaozong 发表于 2019-12-7 15:12

感谢帮助，亲测有效，可以把粘贴的设置成一键粘贴吗？比如选择B2，自动把4张图粘贴到B2：C3。
因实际工作中每天都会根据数据自动生成300多张图表，如果都一个区域一个区域点，也要花不少时间

yaozong

753227299 发表于 2019-12-8 11:40
感谢帮助，亲测有效，可以把粘贴的设置成一键粘贴吗？比如选择B2，自动把4张图粘贴到B2：C3。
...

Sub Export3()
    Sheets("图片").Activate
    Dim cel As Range, m&, n&, x&, y&, p As Shape
    For Each p In ActiveSheet.Shapes
        p.Cut
    Next
    For Each cel In Sheets("原图").Range("b2:c3")
        m = m + 1: n = n + 1
        cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        If m = 1 And n = 1 Then
            Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
            rng.Select
        Else
            x = IIf(m = 2, 0, 1)
            y = IIf(n = 3, 0, 1)
            rng.Offset(x, y).Select
        End If
        ActiveSheet.Paste
    Next
End Sub

yaozong

1. Sub Export3()
   
2.     Sheets("图片").Activate
   
3.     Dim cel As Range, m&, n&, x&, y&, p As Shape
   
4.     For Each p In ActiveSheet.Shapes
   
5.         p.Cut
   
6.     Next
   
7.     For Each cel In Sheets("原图").Range("b2:c3")
   
8.         m = m + 1: n = n + 1
   
9.         cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
10.         If m = 1 And n = 1 Then
    
11.             Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
    
12.             rng.Select
    
13.         Else
    
14.             x = IIf(m = 2, 0, 1)
    
15.             y = IIf(n = 3, 0, 1)
    
16.             rng.Offset(x, y).Select
    
17.         End If
    
18.         ActiveSheet.Paste
    
19.     Next
    
20. End Sub
    

复制代码

753227299

yaozong 发表于 2019-12-8 11:55

谢谢老师帮助