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

相应代码:
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
嘻嘻,写在最后:此贴暂作备忘。
原数据环境如下

相应代码:
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
嘻嘻,写在最后:此贴暂作备忘。

吼吼,撒花一个,这个代码我抱走了……












