I have an excel worksheet with a lot of pictures with various sizes and formats. I want to use excel VBA to loop through all the pictures in the worksheet, and set each picture to the same width (214) and change the picture type to a JPEG after resizing (to keep the file size down). My pictures are located in various cells, and I don’t want the picture locations to change (i.e. stay in the same cell). I’m new to VBA and tried the following – but it doesn’t work. The debugger stops at the line where I’m trying to cut the picture.
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
It’s not the cutting part that Excel doesn’t like–it’s the pasting part.
PasteSpecial are methods you call with a worksheet object (where you’re pasting to) instead of the image (the thing you’re pasting). I don’t know if you want to just shrink the width and hold the height constant or if you want to scale both dimensions evenly. If you want to scale both evenly, try this:
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
If you’re just trying to shrink the width and leave the height the same, try this:
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
The locations of your pictures should stay exactly the same if they were originally right at the corner of a cell. Otherwise, this will align the top left corner of the image to the nearest cell corner. The
Application.CutCopyMode = False is good practice after pasting. It tells Excel to wipe the clipboard and go back to normal operation instead of waiting for you to paste again. Hope this helps.
Thanks for answering my question! Here’s the code I ended up using based on your suggestions. The program took several minutes to run (had over 5000 pictures in the file – yikes!). However, it was worth the wait, because it shrunk the file size in half.
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