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