如何实现图片填满单元格

大家可能经常需要在工作表单元格中插入图片，为了满足OCD领导的要求，图片一定要占满整个单元格，也就是这个效果。

天有不测风云，我有录制宏法宝，祭出法宝收了这妖孽需求。

依次点击【插入】>【图片】>【此设备】，选择本地图片，调整图片尺寸，使得图片填充满A1单元格，哒哒，揍是这么简单。

Sub 宏1()
    ActiveSheet.Pictures.Insert("C:\Temp\xmas-sq.jpg").Select
    Selection.ShapeRange.ScaleWidth 0.1803221656, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.1803221656, msoFalse, msoScaleFromTopLeft
End Sub

给领导交差前，再测试一下，删除图片，选择A1单元格，运行录制的宏代码，这是什么鬼，图片怎么变成这么小一丢丢了。

研究一下代码，法宝有时也会掉链子，ScaleWidth 0.18将图片缩小为原尺寸的0.18，ScaleHeight 0.18将图片再次缩小0.18，注意此时不是原始图片尺寸的0.18，而是ScaleWidth缩放后的图片的0.18，实际上图片缩小为0.18 * 0.18 = 0.0324。

既然找到了原因，DIY一下，再次测试法宝，这次的结果没有问题了，ScaleWidth和ScaleHeight保留任何一行，效果都是相同的。

Sub 宏2()
    ActiveSheet.Pictures.Insert("C:\Temp\xmas-sq.jpg").Select
    Selection.ShapeRange.ScaleWidth 0.1803221656, msoFalse, msoScaleFromTopLeft
    'Selection.ShapeRange.ScaleHeight 0.1803221656, msoFalse, msoScaleFromTopLeft
End Sub

换个图片再次测试，又出幺蛾子了，怎么不是填满的效果！

Sub 宏3()
    ActiveSheet.Pictures.Insert("C:\Temp\xmas.jpg").Select
    Selection.ShapeRange.ScaleWidth 0.1803221656, msoFalse, msoScaleFromTopLeft
    'Selection.ShapeRange.ScaleHeight 0.1803221656, msoFalse, msoScaleFromTopLeft
End Sub

据传，法宝（录制宏的代码）需要优化一下，才能降妖伏魔，先用录制宏时插入的图片验证一下，在代码中直接设置图片的Height和Width属性，分别等于A1单元格的高度和宽度。运行一下代码，效果杠杠的。

Sub Demo1()
    [a1].Select
    With ActiveSheet.Pictures.Insert("C:\Temp\xmas-sq.jpg")
        .Height = [a1].Height
        .Width = [a1].Width
    End With
End Sub

换个图片继续测试，仍然是惨不忍睹的效果。

Sub Demo2()
    [a1].Select
    With ActiveSheet.Pictures.Insert("C:\Temp\xmas.jpg")
        .Height = [a1].Height
        .Width = [a1].Width
    End With
End Sub

为啥呢？研究一下这两个图片的区别，其分辨率不同，Xmastree是正方形图片，xmas并不是正方形的，然而插入的图片默认“锁定纵横比”，因此xmas并不能填满单元格。

既然已经找到问题根源，那么在代码中取消锁定纵横比就可以了。

Sub Demo3()
    [a1].Select
    With ActiveSheet.Pictures.Insert("C:\Temp\xmas.jpg")
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = [a1].Height
        .Width = [a1].Width
    End With
End Sub

再次运行代码，完美实现图片拉伸填满单元格。