ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12
返回列表 发新帖
楼主: 753227299

[求助] 如何用VBA复制图表到指定位置,并粘贴为JPG

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-8 19:16 | 显示全部楼层
坛子里的大师都是好人

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-8 20:07 | 显示全部楼层

老师,再请教您一下,如果第7行“原图”区的区域变成B2:F6后,14,15行应该怎么调整呀?我自己试了一下m=5,n=6,点击B2后,发现还是全复制在“图片”区的B2:D3;而且B2,B3,D2都是一张,剩余图片都在D3里,才学VBA没多久,这些命令还不明其理,望能告知,感谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-8 20:19 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
pinezh 发表于 2019-12-8 19:16
坛子里的大师都是好人

是啊,感谢各位大师的帮助,向各位大师看齐,争取早日学会灵活运用VBA

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-8 20:32 | 显示全部楼层

老师,您好,另外,我发现再次执行命令时,粘贴到“图片”区的图片就不在了,不知道您能帮我再看看嘛,感谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-8 21:43 | 显示全部楼层

老师,您好,刚才学习了下循环语句,明白了运算规则,如果复制区域为B2:F6,则需要把14,15行改成   
x = IIf(m <= 5, 0, IIf(m <= 10, 1, IIf(m <= 15, 2, IIf(m <= 20, 3, 4))))
y = IIf(n = 1 Or n = 6 Or n = 11 Or n = 16 Or n = 21, 0, IIf(n = 2 Or n = 7 Or n = 12 Or n = 17 Or n = 22, 1,  IIf(n = 3 Or n = 8 Or n = 13 Or n = 18 Or n = 23, 2, IIf(n = 4 Or n = 9 Or n = 14 Or n = 19 Or n = 24, 3, 4))))
现在还没搞明白就是如何再次运行时,不删除已粘贴的图片,请求告知,谢谢

TA的精华主题

TA的得分主题

发表于 2019-12-9 06:59 | 显示全部楼层
753227299 发表于 2019-12-8 21:43
老师,您好,刚才学习了下循环语句,明白了运算规则,如果复制区域为B2:F6,则需要把14,15行改成   
x  ...

图片好多时,要集选分贴者,粘贴点应计算与第一只图片的偏移量。

TA的精华主题

TA的得分主题

发表于 2019-12-9 07:01 | 显示全部楼层
试下

Sub Export4() ''选区中各图片按粘贴首图位置对应粘贴
    Sheets("图片").Activate
    'Application.ScreenUpdating = False
    Dim rng As Range, cel As Range, m&, n&, r&, c&, p As Shape
    Dim ar(), br(), rh#, cw#
    For Each p In ActiveSheet.Shapes
        p.Cut
    Next
    For Each cel In Sheets("原图").Range("b2:c3")
        rh = cel.RowHeight
        cw = cel.ColumnWidth
        m = m + 1
        If m = 1 Then: r = cel.Row: c = cel.Column
        ReDim Preserve ar(1 To m)
        ReDim Preserve br(1 To m)
        ar(m) = cel.Row - r
        br(m) = cel.Column - c
        cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        If m = 1 Then
            Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
            rng.Select
        Else
            rng.Offset(ar(m), br(m)).Select
        End If
        Selection.RowHeight = rh
        Selection.ColumnWidth = cw
        ActiveSheet.Paste
    Next
    'Application.ScreenUpdating = True
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-9 09:08 | 显示全部楼层
yaozong 发表于 2019-12-9 07:01
试下

Sub Export4() ''选区中各图片按粘贴首图位置对应粘贴

感谢老师帮助!

TA的精华主题

TA的得分主题

发表于 2019-12-9 10:45 | 显示全部楼层

不删除已粘贴的图片时,

Sub Export4() ''选区中各图片按粘贴首图位置对应粘贴
    Sheets("图片").Activate
    Dim rng As Range, cel As Range, m&, n&, r&, c&, p As Shape
    Dim ar(), br(), rh#, cw#
    For Each p In ActiveSheet.Shapes ''这一循环是删除原粘贴的图片(不删除时,这循环不用)
        p.Cut
    Next
    For Each cel In Sheets("原图").Range("b2:c3")
        rh = cel.RowHeight
        cw = cel.ColumnWidth
        m = m + 1
        If m = 1 Then: r = cel.Row: c = cel.Column
        ReDim Preserve ar(1 To m)
        ReDim Preserve br(1 To m)
        ar(m) = cel.Row - r
        br(m) = cel.Column - c
        cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        If m = 1 Then
            Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
            rng.Select
        Else
            rng.Offset(ar(m), br(m)).Select
        End If
        Selection.RowHeight = rh
        Selection.ColumnWidth = cw
        ActiveSheet.Paste
    Next
End Sub


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 21:40 , Processed in 0.045995 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表