摘要：
工作量繁重而乏味。有什么办法解决这个问题吗？
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.95rtoH = 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) / 2Selection.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.95rtoH = cellH / picH * 0.95If 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) / 2End 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键和方向键，可以实现对图片的位置的进行微调。