Excel VBA，VBA程序代码改变图片内容
假如现在有两幅不同图片，图片1，图片2，要求用VBA代码改变图片1的内容为图片
看清问题了噢，只求一行VBA程序代码，其他说再多是没用的~
可能我没有描述清楚噢，图片1，图片2是已经存在Excel的页面中的，而不是文件夹下的。 展开
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当更改单元格内容或者因为计算而引起单元格内容变化时，将在对应位置更新图片，最终效果如下：
下面以jpg图片为例：
Sub lqxs()
Dim Filename$
Filename = Application.GetOpenFilename("JPG Files (*.jpg), *.jpg", , "请选取文件", , MultiSelect:=False)
If Filename <> "" Then
ActiveSheet.Pictures.Insert (Filename)
End If
ActiveSheet.Shapes(Application.Caller).Select
Selection.Delete
End Sub
1、要图片1显示图片2可用代码：
Image1.Picture = Image2.Picture
2、要让图片1不显示图片（无签名）可用代码：
Image1.Picture = LoadPicture("")
其实我真的很想给你最佳答案，简介精炼，就是我想要的，只可惜运行不出来。
给我个邮箱地址，我发个Excel给你测试
ActiveSheet.Shapes("Picture 1").Visible = False
Selection.InlineShapes.AddPicture FileName:="C:\图片2", LinkToFile:=False, SaveWithDocument:=True
