求教图片怎么自动调整大小并铺满整个单元格，而且合并单元格也同样生效

沈晓冲

比如选中一个单元格或者合并之后的单元格，点击一个插入按钮图片插入之后会自动铺满单元格（哪怕比例失调也无所谓，一定要铺满），这个功能在论坛其实能找到，但问题就是合并的单元格就不适用了，求大神指导

3190496160

上传你的excel附件，才可能针对你的需求来写代码的

taller

taller

沈晓冲

目前可以实现上传图片到指定单元格，单击图片可以放大再次单击恢复原样，但是插入的图片不能铺满，而且合并后的单元格无效；求大神修改

Sub 插入图片()
Dim filenames As String
Dim filefilter1 As String
filefilter1 = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")    '所有图片文件后面的括号为中文括号
filenames = Application.GetOpenFilename(filefilter1, , "请选择一个图片文件", , MultiSelect:=False)
'没有选中文件时，做容错处理
If filenames = "False" Then Exit Sub
'插入图片到指定的单元格
Sheet1.Pictures.Insert(filenames).Cut
Sheet1.Pictures.Paste.Select

'图片自适应单元格大小
On Error Resume Next
Dim picW As Single, picH As Single
Dim cellW As Single, cellH As Single
Dim rtoW As Single, rtoH As Single
cellW = ActiveCell.Width
cellH = ActiveCell.height
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.height
rtoW = cellW / picW * 0.95
rtoH = cellH / picH * 0.95
If rtoW < rtoH Then
    Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
Else
    Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
End If
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.height
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2
With Selection
    .OnAction = "test"
    .Name = ActiveCell.Address(0, 0)
    .AlternativeText = Empty
End With
[a1].Select
End Sub

taller

沈晓冲 发表于 2024-2-22 13:29
目前可以实现上传图片到指定单元格，单击图片可以放大再次单击恢复原样，但是插入的图片不能铺满，而且合并 ...

请参考3楼代码，取消锁定纵横比，然后再调整比例