巴蜀兄弟连吧 关注:60贴子:246

根据图片名称插入相应图片

只看楼主收藏回复

解决方案:创建矩形,将相应图片作为矩形的填充就行了。
原数据环境如下

相应代码:
Sub test()
Dim rg As Range, shp As Shape
For i = 2 To Cells(Rows.Count, "A").End(3).Row
Set rg = Cells(i, "B")
ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
Selection.ShapeRange.Fill.UserPicture "E:\图片\" & rg.Offset(0, -1) & ".jpg"
Next
End Sub
如果反复执行上述代码,会重复在同一位置插入图片,导致文件增大,所以,最好在执行代码前,清除所有图形对象
Sub test()
Dim rg As Range, shp As Shape
*---------------------------------------------------
*清除图形对象
For Each shp In ActiveSheet.Shapes
shp.Delete
Next
*---------------------------------------------------
*按名称插入图片
For i = 2 To Cells(Rows.Count, "A").End(3).Row *根据A列开始循环处理
Set rg = Cells(i, "B")
ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select *添加矩形
Selection.ShapeRange.Fill.UserPicture "E:\图片\" & rg.Offset(0, -1) & ".jpg" *在矩形内部用图片填充
Next
End Sub
嘻嘻,写在最后:此贴暂作备忘。


1楼2014-09-14 14:41回复
    老大,这个代码导进来的图片是跟给定单元格差不多大小的吗???


    2楼2014-09-16 16:27
    收起回复
      2025-12-28 22:59:12
      广告
      不感兴趣
      开通SVIP免广告
      注:代码中的*号,应该为英文单引号。
      百度抽风,擅自主张将英文单引号写成了*号。
      使用者自行更正。
      下面是更正后的代码
      Sub test()
      Dim rg As Range, shp As Shape
      Rem ---------------------------------------------------
      Rem 清除图形对象
      For Each shp In ActiveSheet.Shapes
      shp.Delete
      Next
      Rem ---------------------------------------------------
      Rem 按名称插入图片
      Rem 下行代码,根据A列开始循环处理
      For i = 2 To Cells(Rows.Count, "A").End(3).Row
      Set rg = Cells(i, "B")
      Rem 下面代码,添加矩形
      ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
      Rem 下面代码,在矩形内部用图片填充
      Selection.ShapeRange.Fill.UserPicture "E:\图片\" & rg.Offset(0, -1) & ".jpg"
      Next
      End Sub


      4楼2014-09-17 12:23
      收起回复
        吼吼,撒花一个,这个代码我抱走了……


        5楼2014-09-18 12:50
        回复
          百度查找 一进来居然是贴吧 必须码一个


          6楼2015-04-20 11:27
          回复
            厉害!跟我师父差不多


            IP属地:四川7楼2016-01-05 19:16
            回复
              谢谢LZ,不能自动执行吗?每次输入需要点宏执行才可以,删除名称对应图片也不会消失


              8楼2016-08-09 11:19
              回复
                感谢楼主发布如此实用的代码,太感谢!


                9楼2016-10-06 13:22
                回复
                  2025-12-28 22:53:12
                  广告
                  不感兴趣
                  开通SVIP免广告
                  提示文件未找到


                  IP属地:福建10楼2016-11-13 17:10
                  回复
                    收了,效果非常好


                    11楼2017-04-15 20:28
                    回复
                      配合批量该图片名称的脚本在一起效果杠杆的


                      12楼2017-04-15 20:29
                      回复
                        其中有一個圖片名稱沒有對應的圖片下面的就接著不顯示了,可以加一條沒有對應圖片單元格為空繼續執行下面的操作嗎?謝謝


                        13楼2017-10-18 14:49
                        收起回复
                          楼主,我要更改输入单位格和显示图片的单元格 ,要如何修改?


                          IP属地:云南14楼2018-11-02 11:26
                          收起回复
                            楼主为什么我的不行呢?这个代码有错吗?麻烦你指导下。谢谢!

                            Sub test()
                            Dim rg As Range, shp As Shape
                            Rem ---------------------------------------------------
                            Rem 清除图形对象
                            For Each shp In ActiveSheet.Shapes
                            shp.Delete
                            Next
                            Rem ---------------------------------------------------
                            Rem 按名称插入图片
                            Rem 下行代码,根据A列开始循环处理
                            For i = 2 To Cells(Rows.Count, "A").End(3).Row
                            Set rg = Cells(i, "B")
                            Rem 下面代码,添加矩形
                            ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
                            Rem 下面代码,在矩形内部用图片填充
                            Selection.ShapeRange.Fill.UserPicture "E:\图片\" & rg.Offset(0, -1) & ".jpg"
                            Next
                            End Sub


                            IP属地:广东15楼2020-01-07 00:50
                            收起回复
                              2025-12-28 22:47:12
                              广告
                              不感兴趣
                              开通SVIP免广告
                              如何批量将指定图片放到指定excel指定位置并设置大小


                              IP属地:天津16楼2020-04-28 20:35
                              回复