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 Elsex1 = 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 Thenjinggao:
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 IfNext
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 ThenIf flagch Then
flagch = False
Set rng = rg
End If
Set rng = Union(rng, rg)
End If End If NextNext
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 = TrueNext
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.ShapesIf 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 = FalseNext
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 NextNext
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 NextNext
For Each rg In Target
If rg <> False And flag And flag1 Then '圖庫中找到相符圖片且對應位置尚無對應圖片,則插入圖片 For Each p In Sh.Shapes For Each rg1 In TargetIf 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 Elseerr:
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 IfNext
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 NextNext
Application.ScreenUpdating = True '打開刷屏
Application.DisplayAlerts = True '打開警告和消息
End Sub
5當更改單元格內容或者因為計算而引起單元格內容變化時，將在對應位置更新圖片，最終效果如下：