插入图片_输入图片名称自动插入对应图片

今天继续接上一次的话题，聊聊插入图片的那些事。

不知上一篇的代码，大家用的还顺不顺手。至少可以解决大部分问题了。

不过只是这样还不够，点一下按钮还是会消耗大量卡路里，我们要把懒的思想贯彻到底才对。

还是上一个栗子，把图片插入到对应单元格。

请看动画：

可能没有看清，现在慢放×100倍：

代码如下：

向左滑动查看更多

Private Sub Worksheet_Change(ByVal Target As Range)On Error Resume NextDim filepath As StringDim picname As StringDim rng As RangeDim Rg As RangeDim SH As ShapeDim arrDim i As LongDim x As LongIf Target.Column <> 1 Then Exit Sub '不是A列即终止-----需修改Set rng = Cells(Target.Row, 2) '图片需要插入到第二列(即B列)-----需修改For Each SH In ActiveSheet.ShapesIf Not Intersect(rng, SH.TopLeftCell) Is Nothing Then SH.DeleteNext
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    picname = Cells(Target.Row, 1).Text '从第一列(即A列)得到图片名称，并以此名查找图片-----需修改If picname = "" Then Exit Sub
    arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    filepath = ThisWorkbook.Path & "\图片\" & picname  '图片文件存储的路径与名称-----需修改For i = 0 To UBound(arr)If Len(Dir(filepath & arr(i))) Then '存在相关图片文件
            ActiveSheet.Pictures.Insert(filepath & arr(i)).SelectWith Selection'锁定高宽比
                .ShapeRange.LockAspectRatio = True'大小和位置随单元格而变
                .Placement = xlMoveAndSizeIf .Height / .Width > rng.MergeArea.Height / rng.MergeArea.Width Then
                .Height = rng.MergeArea.Height * 0.8
                .Top = rng.MergeArea.Top + (rng.MergeArea.Height - .Height) / 2
                .Left = rng.MergeArea.Left + (rng.MergeArea.Width - .Width) / 2Else
                .Width = rng.MergeArea.Width * 0.8
                .Left = rng.MergeArea.Left + (rng.MergeArea.Width - .Width) / 2
                .Top = rng.MergeArea.Top + (rng.MergeArea.Height - .Height) / 2End IfEnd WithEnd IfNext
Application.ScreenUpdating = True
Application.DisplayAlerts = TrueEnd Sub

Tips：

▎1.代码同样需要根据表格进行修改，需要修改的地方已添加注释。

▎2.执行原理：当指定的那列单元格有内容时自动运行代码。

▎3.这次的代码不需要放在模块里，而是放在对应的sheet中，具体请看慢放。

就酱吧。

希望对你有用o(≧v≦)o

-END- 往期精彩： 01.VBA丨 批量插入图片02.VBA丨移动指定文件 03.VBA丨批量合并工作表Plus

▲长按识别关注