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

 

或

Sub setpic1()
    Dim p As Shape, d$
    Dim sSheet As Worksheet '源工作表
    Set sSheet = Worksheets("Sheet1")

    For Each p In sSheet.Shapes
        p.LockAspectRatio = msoFalse
        d = p.TopLeftCell.Address
        p.Height = Range(d).Height
        p.Width = Range(d).Width
        p.Top = Range(d).Top
        p.Left = Range(d).Left
    Next
End Sub

 

缺陷：VBA代码多次运行时，图片会移动到其他单元格，不推荐使用

 

---

 

二、插入指定图片到选中的单元格并适应大小

推荐使用

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
    End If
    
    '插入图片到指定的单元格
    Sheet1.Pictures.Insert(filenames).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

End Sub

 

 

来自：

https://blog.csdn.net/yinming4u/article/details/49120933

---

 

三、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键和方向键，可以实现对图片的位置的进行微调。