1、ALT+F11打开VBE编辑器，新建一个模块1，输入如下代码：Sub picxz() '以插入图片文件原名称作为图形名称，单元格大小为基准，依次先行方向再列方向插入，即先A1,A2....再B1,B2....依次类推Dim picname As Variant, p As Shape, pname As String, stly, p1 As Shape, pnamewr As String, x As Byte, x1 As Byte, itop, ileft, iheight, iwidth, l As Long, h As LongConst hs As Long = 65536 '每列所能插入图片的最大个数stly = vbQuestion & vbYesNol = -Int(-Sheets("图库").Shapes.Count / hs) '列号h = Sheets("图库").Shapes.Count - (l - 1) * hs '行号picname = Application.GetOpenFilename(FileFilter:="图片文件 (*.jpg; *.gif;*.bmp),*.jpg; *.gif;*.bmp,所有文件(*.*),*.*", _ Title:="图片选择", MultiSelect:=False)If picname <> False Thenpname = Split(Dir(picname), ".", 2)(0) '取图片文件原名称pnamewr = pnameitop = Sheets("图库").Cells(h, l).Top '确定坐标ileft = Sheets("图库").Cells(h, l).Leftiheight = Sheets("图库").Cells(h, l).Height '确定大小iwidth = Sheets("图库").Cells(h, l).WidthFor Each p In Sheets("图库").ShapesIf p.Name = pname Thenx = MsgBox("发现你的图库中已经存在同名图片，请确定是否为新图片？", stly, "图片重名，警告！")If x = 7 ThenExit SubElsex1 = MsgBox("您确定需要替换名为：《" & pname & "》的图片吗？", stly, "图片替换,警告！")If x1 = 6 Thenitop = Sheets("图库").Shapes(pname).Topileft = Sheets("图库").Shapes(pname).Leftiheight = Sheets("图库").Shapes(pname).Heightiwidth = Sheets("图库").Shapes(pname).WidthSheets("图库").Shapes(pname).DeleteElsechongshu:If pnamewr = "" Thenpnamewr = InputBox("您尚未对图片命名，需要正确命名，方能插入此图片！", "图片命名")Elsepnamewr = InputBox("您的图库已经存在以《" & pnamewr & "》为名称的图片，需要重新命名，方能插入此图片！", "图片命名")End IfIf pnamewr = "" Or pnamewr = pname Thenjinggao:MsgBox "警告！输入为空或为同名！请继续输入", vbExclamation, "图片命名警告！"GoTo chongshuEnd IfFor Each p1 In Sheets("图库").Shapes If p1.Name = pnamewr Then GoTo jinggaoNextEnd IfEnd IfEnd IfNext ActiveSheet.Pictures.Insert(picname).Select With Selection.ShapeRange .Name = pnamewr .LockAspectRatio = msoFalse .Top = itop .Left = ileft .Height = iheight .Width = iwidth .Rotation = 0# End WithEnd IfEnd Sub
2、新建一个工作表取名为：“图库”。
3、左键单击菜单：视图-工具栏-窗体，用窗体工具栏上的按钮控件，在图库工作表，左键拖拉画出一个按钮，名称改为插入图片，指定宏为picxz，然后随机插入几张图片。效果如下：
4、ALT+F11打开VBE编辑器，在ThisWorkbook中粘贴如下代码： Option Explicit C泠贾高框onst ofsrow As Integer = 0, ofscol As Integer = 1 '插入图片相对单元格的位置,即在ofsrow行、ofscol列，位置插入 Private Sub Workbook_SheetCalculate(ByVal Sh As Object) On Error Resume Next Dim pic As Shape, rg As Range, flagch As Boolean, rng As Range, flagempty As Boolean, pic1 As Shape, flagcf As Boolean flagch = True '标记相对应位置是否有对应图片，默认有 flagempty = True '标记相对应位置是否无任何图片,默认是 flagcf = False '标记相对应位置对应图片是否有重复,默认无 Application.ScreenUpdating = False '关闭刷屏 Application.DisplayAlerts = False '关闭警告和消息 Sh.UsedRange.SpecialCells(xlCellTypeFormulas).Select '选中已经编辑且含有公式单元格区域 For Each rg In Selection For Each pic In Sh.Shapes If InStr(1, pic.Name, "Drop Down") = 0 Then If pic.Name <> rg.Value And pic.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address Then If flagch Then flagch = False Set rng = rg End If Set rng = Union(rng, rg) End If End If Next Next For Each rg In Selection For Each pic In Sh.Shapes If InStr(1, pic.Name, "Drop Down") = 0 Then If rg.Offset(ofsrow, ofscol).Address = pic.TopLeftCell.Address Then flagempty = False End If Next If flagch And flagempty Then Set rng = rg flagch = False End If If flagch = False And flagempty Then Set rng = Union(rng, rg) flagempty = True Next rng.Select '将无对应图片的相对应位置选中 If flagch = False Then For Each rg In Selection For Each pic In Sheets("图库").Shapes If rg.Value = pic.Name And rg.Offset(ofsrow, ofscol).Address <> pic.TopLeftCell.Address Then '在图库找到相对应图片,且相应位置无对应图片,则插入图片 For Each pic1 In Sh.Shapes If InStr(1, pic1.Name, "Drop Down") = 0 Then If pic1.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And pic1.Name <> rg.Value Then pic1.Delete '将相对应位置名称不符的图片删除 End If Next pic.Copy Sh.Select rg.Offset(ofsrow, ofscol).Select ActiveSheet.Paste With Selection.ShapeRange .LockAspectRatio = msoFalse .Left = rg.Offset(ofsrow, ofscol).Left + rg.Offset(ofsrow, ofscol).Width / 20 .Top = rg.Offset(ofsrow, ofscol).Top .Height = rg.Offset(ofsrow, ofscol).Height .Width = rg.Offset(ofsrow, ofscol).Width * 0.95 End With rg.Select End If Next Application.CutCopyMode = False For Each pic1 In Sh.Shapes If InStr(1, pic1.Name, "Drop Down") = 0 Then If pic1.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And pic1.Name = rg.Value And flagcf Then pic1.Delete '对应位置相符但重复的图片删除 If pic1.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And pic1.Name <> rg.Value Then pic1.Delete '对应位置不符的图片删除 If pic1.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And pic1.Name = rg.Value And flagcf = False Then flagcf = True End If Next flagcf = False Next End If Application.ScreenUpdating = True '打开刷屏 Application.DisplayAlerts = True '打开警告和消息 End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) On Error Resume Next Dim flag As Boolean, flag1 As Boolean, p As Shape, rg As Range, rg1 As Range flag = True '标记对应位置是否已含有相符图片,默认不含有 flag1 = False '标记图库中是否含有相符图片,默认不含有 Application.ScreenUpdating = False '关闭刷屏 Application.DisplayAlerts = False '关闭警告和消息 For Each p In Sh.Shapes For Each rg In Target If InStr(1, p.Name, "Drop Down") = 0 Then If p.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And p.Name = rg.Value Then flag = False End If Next Next For Each p In Sheets("图库").Shapes For Each rg In Target If InStr(1, p.Name, "Drop Down") = 0 Then If p.Name = rg.Value Then flag1 = True End If Next Next For Each rg In Target If rg <> False And flag And flag1 Then '图库中找到相符图片且对应位置尚无对应图片,则插入图片 For Each p In Sh.Shapes For Each rg1 In Target If InStr(1, p.Name, "Drop Down") = 0 Then If p.TopLeftCell.Address = rg1.Offset(ofsrow, ofscol).Address Then p.Delete End If Next Next Sheets("图库").Shapes(rg.Value).Copy Sh.Select rg.Offset(ofsrow, ofscol).Select ActiveSheet.Paste On Error GoTo err If rg.Validation.Type Then '是否含数据有效性 With Selection.ShapeRange .LockAspectRatio = msoFalse .Left = rg.Offset(ofsrow, ofscol).Left + rg.Offset(ofsrow, ofscol).Width / 4 .Top = rg.Offset(ofsrow, ofscol).Top .Height = rg.Offset(ofsrow, ofscol).Height .Width = rg.Offset(ofsrow, ofscol).Width * 0.75 End With Else err: With Selection.ShapeRange .LockAspectRatio = msoFalse .Left = rg.Offset(ofsrow, ofscol).Left + rg.Offset(ofsrow, ofscol).Width / 20 .Top = rg.Offset(ofsrow, ofscol).Top .Height = rg.Offset(ofsrow, ofscol).Height .Width = rg.Offset(ofsrow, ofscol).Width * 0.95 End With End If rg.Select End If Next Application.CutCopyMode = False For Each p In Sh.Shapes For Each rg In Target If InStr(1, p.Name, "Drop Down") = 0 Then If p.TopLeftCell.Address = rg.Offset(ofsrow, ofscol).Address And p.Name <> rg.Value Then p.Delete End If Next Next Application.ScreenUpdating = True '打开刷屏 Application.DisplayAlerts = True '打开警告和消息 End Sub
5、当更改单元格内容或者因为计算而引起单元格内容变化时，将在对应位置更新图片。（实例请至http://pan.baidu.com/s/1R9LG下载newinsertpic.xls），最终效果如下：
