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當更改單元格內容或者因為計算而引起單元格內容變化時，將在對應位置更新圖片，最終效果如下：