麻烦大神能帮我写一个EXCEL VBA宏批量导出A列图片并按B列命名

QQ1123558446 · 发表于 2019-9-11 12:01

图片导出.zip (328.12 KB, 下载次数: 28)

爱疯 · 发表于 2019-9-11 15:51

Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"
For Each x In Sheet1.Shapes
      Call Chart2Pic(x, p & x.TopLeftCell.Offset(0, 1) & ".jpg")
Next
End Sub

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

hzg303 · 发表于 2019-9-20 02:08

爱疯发表于 2019-9-11 15:51
Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"

测试了么，导出的是空白呀

爱疯 · 发表于 2019-9-20 08:35

图片导出2.rar (323.55 KB, 下载次数: 63)

1123558446 · 发表于 2019-9-29 10:05

爱疯发表于 2019-9-20 08:35

大神导出来的数量少了好多麻烦再看看哈

爱疯 · 发表于 2019-9-29 10:18

1123558446 发表于 2019-9-29 10:05
大神导出来的数量少了好多麻烦再看看哈

相同的货号多吗？必须有附件，才可能找出原因

Wei_Ran_ · 发表于 2020-3-26 17:03

爱疯发表于 2019-9-11 15:51
Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"

您好，我的文件现在是名称和图片横向排列，第一行是图片，第二行是图片名称，请问怎么修改一下VBA后可以使用，而且希望导出来的图片是文件中的原始分辨率，我自己试过把offset的参数调整了一下，图片确实导出了一部分，但是有缺失，就会导致后面的图片与名称错位，且图片信息分辨率大大降低，求大神帮忙写一个能满足需要的VBA吧，感激不尽！

爱疯 · 发表于 2020-3-26 17:35

Wei_Ran_ 发表于 2020-3-26 17:03
您好，我的文件现在是名称和图片横向排列，第一行是图片，第二行是图片名称，请问怎么修改一下VBA后可以 ...

Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"
For Each x In Sheet1.Shapes
      Call Chart2Pic(x, p & x.TopLeftCell.Offset(1, 0) & ".jpg")
Next
End Sub

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

含图片文件2.rar (222.83 KB, 下载次数: 16)

Wei_Ran_ · 发表于 2020-3-26 19:34

爱疯发表于 2020-3-26 17:35
Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"

我的修改方式跟您的一样，结果就像上一条说的那样，那有办法处理吗？感谢大神帮忙想想办法，谢谢啦！

爱疯 · 发表于 2020-3-27 15:03

Sub test()
Dim p, i, x, y
p = ThisWorkbook.Path & "\"
For i = 1 To Sheets(1).Shapes.Count
      Set x = Sheets(1).Shapes(i)
      Set y = Cells(1, i + 1)
      With x
         .Left = y.Left
         .Top = y.Top
         .Width = y.Width
         .Height = y.Height
         Call Chart2Pic(x, p & y.Offset(1, 0) & ".jpg")
      End With
Next i
End Sub

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

含图片文件4.rar (219.51 KB, 下载次数: 24)

		自动登录	找回密码
密码			注册