使用Excel VBA调整和更改多个图片的格式

我有一个excel工作表，有很多不同尺寸和格式的图片。 我想使用excel VBA来遍历工作表中的所有图片，并将每张图片设置为相同的宽度（214），并在resize（将文件大小减小）后将图片types更改为JPEG。 我的图片位于不同的单元格中，我不希望图片位置发生变化（即停留在同一个单元格中）。 我是新来的VBA，并尝试以下 – 但它不工作。 debugging器停在我试图剪切图片的那一行。

Sub Macro6() Dim p As Object Dim iCnt As Integer For Each p In ActiveSheet.Shapes p.Width = 217.44 p.Cut p.PasteSpecial Format:="Picture (JPEG)", Link:=False iCnt = iCnt + 1 Next p End Sub 

Answer 1

这不是Excel不喜欢的切割部分 – 这是粘贴的一部分。 Paste和“ Paste PasteSpecial是您使用工作表对象（您正在粘贴的位置）调用的方法，而不是图像（您正在粘贴的内容）。 我不知道是否只是缩小宽度，并保持高度不变，或者如果你想均衡地缩放两个尺寸。 如果你想均衡缩放，试试这个：

 Sub Macro6() Dim p As Object Dim iCnt As Integer Dim s As Double Dim r As Range For Each p In ActiveSheet.Shapes s = 214 / p.Width Set r = p.TopLeftCell p.Width = 214 p.Height = p.Height * s p.Cut r.Select ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False Application.CutCopyMode = False iCnt = iCnt + 1 Next p End Sub 

如果您只是想缩小宽度并保持高度不变，请尝试以下操作：

 Sub Macro6() Dim p As Object Dim iCnt As Integer Dim r As Range For Each p In ActiveSheet.Shapes Set r = p.TopLeftCell p.Width = 214 p.Cut r.Select ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False Application.CutCopyMode = False iCnt = iCnt + 1 Next p End Sub 

如果图片的原始位置恰好在单元格的angular落，则图片的位置应保持完全相同。 否则，这将使图像的左上angular与最近的单元angularalignment。 在粘贴之后， Application.CutCopyMode = False是很好的做法。 它告诉Excel擦除剪贴板并返回到正常的操作，而不是等待您再次粘贴。 希望这可以帮助。

Answer 2

谢谢回答我的问题！ 这是我根据您的build议结束使用的代码。 该程序花了几分钟的时间运行（在文件中有超过5000张图片 – 哇！）。 然而，值得等待，因为它缩小了一半的文件大小。

 Sub all_pics_to_jpeg() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim mypic As Shape Dim picleft As Double Dim pictop As Double For Each mypic In ActiveSheet.Shapes mypic.LockAspectRatio = msoTrue If mypic.Width > mypic.Height Then mypic.Width = 217.44 Else: mypic.Height = 157.68 End If picleft = mypic.Left pictop = mypic.Top With mypic .Cut ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _ DisplayAsIcon:=False Application.CutCopyMode = False Selection.Left = picleft Selection.Top = pictop End With Next mypic Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub