当前位置：首页 > news >正文

Excel 使用VBA自动调整插入图片大小到单元格

news 来源：原创 2024/5/17 14:49:29

一、前言描述

需要插入文件夹中的图片到excel中，并和对应单元格的名称进行匹配。

二、方法步骤

使用宏来插入图片，并适配单元格

1. 开启宏

点击文件->选项->信任中心->信任中心设置->宏设置->启用VBA宏
在这里插入图片描述

2. 新建一个宏

直接alt+f8,或者点击在【视图】下的宏：
在这里插入图片描述

3. 粘贴宏代码

输入一个宏的名称【InsertPic】，然后点击创建，再使用快捷键ctrl+r打开工程资源管理器，在模块下新建一个：
在这里插入图片描述

代码如下，然后保存：

Sub InsertPic()Dim arr, i&, k&, n&, b As BooleanDim strPicName$, strPicPath$, strFdPath$, shp As ShapeDim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String'On Error Resume Next'用户选择图片所在的文件夹With Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strFdPath = .SelectedItems(1) Else: Exit SubEnd WithIf Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"Set rngData = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)'用户选择需要插入图片的名称所在单元格范围Set rngData = Intersect(rngData.Parent.UsedRange, rngData)'intersect语句避免用户选择整列单元格，造成无谓运算的情况If rngData Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit SubstrWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")'用户输入图片相对单元格的偏移位置。If Len(strWhere) = 0 Then Exit Subx = Left(strWhere, 1)'偏移的方向If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Suby = Val(Mid(strWhere, 2))'偏移的值Select Case xCase "上"Set rngWhere = rngData.Offset(-y, 0)Case "下"Set rngWhere = rngData.Offset(y, 0)Case "左"Set rngWhere = rngData.Offset(0, -y)Case "右"Set rngWhere = rngData.Offset(0, y)End SelectApplication.ScreenUpdating = FalserngData.Parent.Parent.Activate '用户选定的激活工作簿rngData.Parent.SelectFor Each shp In ActiveSheet.Shapes'如果旧图片存放在目标图片存放范围则删除If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.DeleteNextx = rngWhere.Row - rngData.Rowy = rngWhere.Column - rngData.Column'偏移的坐标arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")'用数组变量记录五种文件格式For Each rngEach In rngData'遍历选择区域的每一个单元格strPicName = rngEach.Text'图片名称If Len(strPicName) Then'如果单元格存在值strPicPath = strFdPath & strPicName'图片路径b = False'变量标记是否找到相关图片For i = 0 To UBound(arr)'由于不确定用户的图片格式，因此遍历图片格式If Len(Dir(strPicPath & arr(i))) Then'如果存在相关文件Set shp = ActiveSheet.Shapes.AddPicture( _strPicPath & arr(i), False, True, _rngEach.Offset(x, y).Left + 5, _rngEach.Offset(x, y).Top + 5, _20, 20)shp.SelectWith Selection.ShapeRange.LockAspectRatio = msoFalse'撤销锁定图片纵横比.Height = rngEach.Offset(x, y).Height - 10 '图片高度.Width = rngEach.Offset(x, y).Width - 10 '图片宽度End Withb = True '标记找到结果n = n + 1 '累加找到结果的个数Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环End IfNextIf b = False Then k = k + 1 '如果没找到图片累加个数End IfNextApplication.ScreenUpdating = TrueMsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"
End SubSub 图片适配单元格()End Sub

4. 另保存为后缀名为xlsm文件

在这里插入图片描述
在保存类型中种选择【excel启用宏的工作簿】：

5. 设置快捷键

把宏命令添加到快捷访问上

在这里插入图片描述

6. 使用方式

点击我们的宏快捷图标，在弹出的窗口中选择需要插入图片的区域，然后，选择对应的文件夹
在这里插入图片描述

选择图片文件夹中图片名称对应的单元格，点击确定：
在这里插入图片描述
然后弹出图片需要放置的位置：比如图片名称在B列，图片放在C列，那就是向右偏移1列，即右1。上下左右代表了方向，数字代表偏移的量。

然后就ok啦，代码运行结束后会告之用户一共成功插入了多少张图片，以及失败了多少张。
在这里插入图片描述