如何批量将同一个工作簿下多个工作表中的图片设置随单元格改变位置和大小

桐桐的面包树

请大神们帮忙看下（见附件），工作表有几百个的~~

沈默00

我用WPS，图片可以设置成嵌入单元格里，就会自动调整大小了

excel玉米

Sub 图片设置()
Dim Shp As Shape, sh As Worksheet
For Each sh In Worksheets
  For Each Shp In sh.Shapes
    Shp.Placement = xlMoveAndSize               '大小和位置随单元格而变,如果设为不变，则是xlMove
   ' Shp.Placement = xlMove                      '大小和位置不随单元格而变
  Next Shp
Next sh
    MsgBox "设置完成"
  '  Selection.ShapeRange.LockAspectRatio = msoTrue    ' 按比例
  '  Selection.Placement = xlMoveAndSize               '大小和位置随单元格而变
  '  Selection.PrintObject = msoTrue                   '打印
  '  Selection.Locked = msoTrue                        '锁定
End Sub

ykcbf1100

excel玉米 发表于 2024-3-18 13:01
Sub 图片设置()
Dim Shp As Shape, sh As Worksheet
For Each sh In Worksheets

你的代码并没有达到楼主想要的效果，图片并没有改变。

excel玉米

Sub 图片设置()
Dim Shp As Shape, sh As Worksheet
Dim PicAddr$, rng As Range
For Each sh In Worksheets
  For Each Shp In sh.Shapes
    If Shp.Type = msoPicture Then   '判断 shp 的对象返回值是否为 图片。
       PicAddr = Shp.TopLeftCell.Address(0, 0)
       If sh.Range(PicAddr).MergeCells Then    '判断是合并单元格时
        Set rng = sh.Range(sh.Range(PicAddr).MergeArea.Address)
       End If
       Shp.LockAspectRatio = msoFalse
       Shp.Height = rng.Height - 15
       Shp.Width = rng.Width - 15
       Shp.Top = rng.Top + (Shp.Height - rng.Height) / 2 + 10
       Shp.Left = rng.Left + (Shp.Width - rng.Width) / 2 + 10
    End If
  Next Shp
Next sh
    MsgBox "设置完成"
End Sub

liulang0808

ykcbf1100 发表于 2024-3-18 13:06
你的代码并没有达到楼主想要的效果，图片并没有改变。

可以先把图片完全填充单元格中，再设置图片的属性
sh.Placement = xlMoveAndSize
然后再调整单元格看看

ykcbf1100

liulang0808 发表于 2024-3-18 21:40
可以先把图片完全填充单元格中，再设置图片的属性
sh.Placement = xlMoveAndSize
然后再调整单元格看看

嗯，看一下。

ykcbf1100

excel玉米 发表于 2024-3-18 21:04
Sub 图片设置()
Dim Shp As Shape, sh As Worksheet
Dim PicAddr$, rng As Range

5楼代码可以了。