Excel VBA，VBA程序代码改变图片内容

 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 Long

Const hs As Long = 65536 '每列所能插入图片的最大个数

stly = vbQuestion & vbYesNo

l = -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 Then

pname = Split(Dir(picname), ".", 2)(0) '取图片文件原名称

pnamewr = pname

itop = Sheets("图库").Cells(h, l).Top '确定坐标

ileft = Sheets("图库").Cells(h, l).Left

iheight = Sheets("图库").Cells(h, l).Height '确定大小

iwidth = Sheets("图库").Cells(h, l).Width

For Each p In Sheets("图库").Shapes

 If p.Name = pname Then

 x = MsgBox("发现你的图库中已经存在同名图片，请确定是否为新图片？", stly, "图片重名，警告！")

 If x = 7 Then

 Exit Sub

 Else

x1 = MsgBox("您确定需要替换名为：《" & pname & "》的图片吗？", stly, "图片替换,警告！")

If x1 = 6 Then

itop = Sheets("图库").Shapes(pname).Top

ileft = Sheets("图库").Shapes(pname).Left

iheight = Sheets("图库").Shapes(pname).Height

iwidth = Sheets("图库").Shapes(pname).Width

Sheets("图库").Shapes(pname).Delete

Else

chongshu:

 If pnamewr = "" Then

 pnamewr = InputBox("您尚未对图片命名，需要正确命名，方能插入此图片！", "图片命名")

 Else

 pnamewr = InputBox("您的图库已经存在以《" & pnamewr & "》为名称的图片，需要重新命名，方能插入此图片！", "图片命名")

 End If

 If pnamewr = "" Or pnamewr = pname Then

jinggao:

 MsgBox "警告！输入为空或为同名！请继续输入", vbExclamation, "图片命名警告！"

 GoTo chongshu

 End If

 For Each p1 In Sheets("图库").Shapes

  If p1.Name = pnamewr Then GoTo jinggao

 Next

 End If

 End If

 End If

Next

    ActiveSheet.Pictures.Insert(picname).Select

    With Selection.ShapeRange

     .Name = pnamewr

     .LockAspectRatio = msoFalse

     .Top = itop

     .Left = ileft

     .Height = iheight

     .Width = iwidth

     .Rotation = 0#

    End With

End If

End Sub

2新建一个工作表取名为：“图库”。

3左键单击菜单：视图-工具栏-窗体，用窗体工具栏上的按钮控件，在图库工作表，左键拖拉画出一个按钮，名称改为插入图片，指定宏为picxz，然后随机插入几张图片。效果如下：

4 ALT+F11打开VBE编辑器，在ThisWorkbook中粘贴如下代码：

Option Explicit

Const 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当更改单元格内容或者因为计算而引起单元格内容变化时，将在对应位置更新图片，最终效果如下：