如何按指定名称快速导出Excel中的图片？

HI，大家好，我是星光。

有朋友询问如何用VBA代码将Excel中的图片导出，并灵活命名。今天就分享解决这个问题的小代码。

照例举个例子。如下图所示，工作表中存在多张图片，现在需要将其导出，并按图片向左偏移一个单元格，也就是A列单元格的值进行命名。

导出后结果如下图所示：

如果不追求规范图片命名，只是导出Excel中的图片，倒不用VBA代码。将工作簿后缀名修改为rar，双击打开，依次点击xl→media即可。

但如果需要规范图片名称，就优先推荐VBA代码了。参考代码如下：

代码复制运行即可

看不全可以左右拖动..▼

Sub ExportPic() Dim strPath As String, strPicName As String, strWhere As String, strPicFullName As String Dim shp As Shape, k As Long, d As Object, x As String, y As Long With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then strPath = .SelectedItems(1) Else: Exit Sub End With strWhere = InputBox('请输入图片名称相对图片所在单元格的偏移位置，例如上1、下1、左1、右1', , '左1') '用户输入图片相对单元格的偏移位置。 If Len(strWhere) = 0 Then Exit Sub x = Left(strWhere, 1) '偏移的方向 If InStr('上下左右', x) = 0 Then MsgBox '你未输入偏移方位。': Exit Sub y = Val(Mid(strWhere, 2)) '偏移的值 Set d = CreateObject('scripting.dictionary') Application.ScreenUpdating = False For Each shp In ActiveSheet.Shapes If shp.Type = msoPicture Then strPicName = GetPicName(x, y, shp.TopLeftCell) If Not d.exists(strPicName) Then d(strPicName) = 1 Else d(strPicName) = d(strPicName) + 1 strPicName = strPicName & d(strPicName) End If strPicFullName = strPath & '\' & strPicName & '.jpg' shp.Copy With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart .Parent.Select .Paste .Export strPicFullName, 'jpg' .Parent.Delete End With End If Next Application.ScreenUpdating = True MsgBox '导出图片完成！' & Chr(13) & '路径：' & strPath, , '提示'End Sub
Function GetPicName(x As String, y As Long, rngShape As Range) As String Dim strPicName As String Select Case x Case '上' strPicName = rngShape.Offset(-y, 0).Value Case '下' strPicName = rngShape.Offset(y, 0) Case '左' strPicName = rngShape.Offset(0, -y) Case '右' strPicName = rngShape.Offset(0, y) End Select GetPicName = IIf(strPicName = '', '图片', strPicName)End Function

今天给大家分享的内容就这些，挥挥手咱们下期再见。