Excel VBA 7.76插入图片，你还在复制粘贴？然后修改大小？正常办公VBA太重要

插入图片，你还在复制粘贴？然后修改大小？正常办公VBA太重要

一起学习，一起进步~~

---

今天我们来学习下Excel和图片之间的一些操作，Excel的强大之处就在于他能够存储很多的东西，不管是控件，数据还是图片都能够存储，给我们的日常工作带来了很大的帮助，但是也有一些操作的不方便，比方说没有批量导入的功能，并且图片的大小无法在导入的时候调整，后期的调整比较的麻烦，非常的不利于操作，那么如何解决这个问题呢？

场景说明

这是我们今天的操作场景，我们电脑本地存在每个员工的头像的照片，并且已经命名了，我们现在希望能够实现的效果是，通过VBA快速的将图片和A列的名字对应起来，然后将头像填充到B列，形成一个员工花名册的效果

如果是手工插入的话，就需要一张张的导入，然后通过鼠标来调整大小，假设有很多员工的话，需要不停的操作，不断的调整图片的大小，非常的麻烦，有些甚至还要调整单元格的大小，这样并不高效，加班逃不掉的，我们来学习下VBA的玩法

代码区

SSub 插入图片()Dim Arr, i&, k&, n&, pd&Dim strPicName$, strPicPath$, strFdPath$, shp As ShapeDim Rng As Range, Cll As Range, Rg As Range, strWhere As StringWith Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then strFdPath = .SelectedItems(1) Else: Exit Sub End IfEnd WithIf Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"End IfSet Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据！" Exit SubEnd IfSet Rg = Rng.Offset(0, 1)Application.ScreenUpdating = FalseRng.Parent.SelectFor Each shp In ActiveSheet.Shapes '删除就的图片 If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.DeleteNextx = 0y = Rg.Column - Rng.ColumnArr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")For Each Cll In Rng strPicName = Cll.Text If Len(strPicName) Then strPicPath = strFdPath & strPicName For i = 0 To UBound(Arr) If Len(Dir(strPicPath & Arr(i))) Then Set shp = ActiveSheet.Shapes.AddPicture(strPicPath & Arr(i), False, True, Cll.Offset(x, y).Left + 5, Cll.Offset(x, y).Top + 5, 20, 20) shp.Select With Selection .ShapeRange.LockAspectRatio = msoFalse .Height = Cll.Offset(x, y).Height - 10 .Width = Cll.Offset(x, y).Width - 10 End With [a1].Select: Exit For '找到结果后就可以退出文件格式循环 End If Next End If Next Application.ScreenUpdating = TrueEnd Sub

可以看到出今天的代码非常的长，好吧，要操作和判断的东西比较的多，确实是代码有点长，不过只要场景相同，完全可以拷贝之后直接使用的

一起来看看效果

从最终的结果来看，有些单元格填充了图片，有些单元格则没有图片，为什么呢？来看看图片是什么样子的

从截图中可以看出来，图片的名称和单元格名称相同的，就成功的被导入了图片，并且同时设置了相同的大小，但是另外的图片名称对应不上的，则没有被填充图片，正好实现了我们的要求

代码解析

来看看今天的代码解析

今天的代码比较的长，我们来一点点慢慢看下

With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then strFdPath = .SelectedItems(1) Else: Exit Sub End IfEnd With

FileDialog方法获取图片所在的文件夹的位置，这个方法相信大家已经很熟悉了，我在之前的代码中经常使用到这样的方法

Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)

这里也很简单，获得图片名称所在的列，也就是我们案例中的A列

Set Rg = Rng.Offset(0, 1)

RG代表的就是要导入图片的单元格，这里我们默认是A列的隔壁一列，即B列，就是offset（0,1）

For Each shp In ActiveSheet.Shapes '删除就的图片If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.DeleteNext

我们都知道，到导入图片的过程中，如果原来的单元格本身有图片的话，还是能够成功导入并且叠加的，

所有未了避免这样的效果出现，我们需要将之前单元格中含有的图片先删除才对，然后才可以插入我们需要的图片

而上面这段代码执行的就是这样的功能

Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")For Each Cll In Rng strPicName = Cll.Text If Len(strPicName) Then strPicPath = strFdPath & strPicName For i = 0 To UBound(Arr) If Len(Dir(strPicPath & Arr(i))) Then Set shp = ActiveSheet.Shapes.AddPicture(strPicPath & Arr(i), False, True, Cll.Offset(x, y).Left + 5, Cll.Offset(x, y).Top + 5, 20, 20) shp.Select With Selection .ShapeRange.LockAspectRatio = msoFalse .Height = Cll.Offset(x, y).Height - 10 .Width = Cll.Offset(x, y).Width - 10 End With [a1].Select: Exit For '找到结果后就可以退出文件格式循环 End If Next End If Next

这一大段代码就是实现图片的插入以及大小设置的功能了

看到这里很多的小伙伴肯定要问，为什么不细细展开，因为图片的插入这里用到了图片shape的属性，在日常工作中图片的使用场景较少，我们只需要掌握一些现成的可用的代码，能够满足实际工作的运用即可，没有必要太深入的学习图片

==========================