VBA实现根据Excel单元格内容自动插入对应图片

VBA实现根据Excel单元格内容自动插入对应图片

VBA实现根据Excel单元格内容自动在指定位置插入存放于相应图库工作表中的对应图片文件方法。效果如下图所示：

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

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

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

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

当更改单元格内容或者因为计算而引起单元格内容变化时，将在对应位置更新图片。（实例请至http://pan.baidu.com/s/1R9LG下载newinsertpic.xls），最终效果如下：