VBA 如何实现让所有图片刚好适应所在单元格大小与表框

Excel疑难千寻千解丛书(三)Excel2010 VBA编程与实践.pdf

Sub 让图片适应单元格()
    Dim sh As Shape
    Dim sSheet As Worksheet '源工作表
      
    Set sSheet = Worksheets("Sheet1")
    
    For Each sh In sSheet.Shapes
        sh.LockAspectRatio = False
        sh.Left = sh.TopLeftCell.Left
        sh.Top = sh.TopLeftCell.Top
        sh.Width = sh.TopLeftCell.Width
        sh.Height = sh.TopLeftCell.Height
        
    Next sh

End Sub

---

excel 批量插入图片且自适应单元格（绝对有效）

https://www.jianshu.com/p/04e462ad4065

1.情景展示

工作中，我们可能会遇到这种情况，需要将拍摄的照片批量插入到excel中
，出现的问题在于：
我们不仅需要将其一个一个的插入到对应的单元格中，还需要将其缩放至合适大小。

 

 

工作量很大且繁琐，有没有办法能够解决这个问题呢？

2.解决方案

实现方式：通过宏命令实现。
第一步：先插入第一张图片（一般情况下，批量导入的图片大小是一致的）；
如上图所示，将图片调整至合适大小；

 

 

第二步：按照图片将单元格调至合适大小，删除该图片；
选中要插入图片的单元格，将其大小调整至和刚才图片的大小一致。

 

 

第三步：鼠标选中要插入第一张图片的单元格；

 

 

第四步：ALT+F11-->打开VBA编辑器-->插入-->模块；

 

 

将下列代码拷贝至弹出的窗口：

Sub 批量插入图片且自适应单元格()

    Dim fileNames As Variant
    Dim fileName As Variant
    Dim fileFilter As String

    '所有图片文件后面的括号为中文括号
    fileFilter = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")
    fileNames = Application.GetOpenFilename(fileFilter, , "请选择要插入的图片", , MultiSelect:=True)

    '循环次数
    Dim i As Single
    i = 0
    '忽略错误继续执行VBA代码，避免出现错误消息（数组fileNames为空时，会报错）
    On Error Resume Next
    '循环插入
    For Each fileName In fileNames

        '将图片插入到活动的工作表中&选中该图片
        With ActiveSheet.Pictures.Insert(fileName).Select

            '图片自适应单元格大小
            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.LockAspectRatio = msoTrue
            '图片的位置与大小随单元格变化而变化
            Selection.Placement = xlMoveAndSize
            '设置该图片的所在位置
            Selection.ShapeRange.IncrementLeft (cellW - picW) / 2 + cellW * i
            Selection.ShapeRange.IncrementTop (cellH - picH) / 2
        End With
        i = i + 1
    '下一个
    Next fileName

End Sub

第五步：按F5运行；
选中你要插入的图片--》打开；

 

 

3.效果展示

 

 

4.扩展说明

4.1 代码说明

 

 

将图片设置为横向排列，代码如下：

'设置该图片的所在位置（图片横向排列）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2 + cellW * i
Selection.ShapeRange.IncrementTop (cellH - picH) / 2

将图片设置为纵向排列，代码如下：

'设置该图片的所在位置（图片纵向排列）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2 + cellH * i

将图片插入到同一位置，代码如下：

'设置该图片的所在位置（图片位于同一位置）
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2

4.2 技巧说明
选中图片，同时按住Shift键和方向键，可以实现对图片的缩小、放大；
选中图片，同时按住Ctrl键和方向键，可以实现对图片的位置的进行微调。