Y你可以使用以下方法实现你想要的Worksheet_Change
event.
为了演示目的,我将使用 3 个电池B4
, C4
and D4
假设我们的图像表(我们称之为PIC
)看起来像这样。
如果您注意到,我在第二行插入了一个空白形状。如果用户按删除键,我们将使用此形状B4
, C4
or D4
。如果没有找到匹配项,我们也将使用此图像。
现在让我们准备我们的主要工作表。按着这些次序
- Select cell
B2
(and not the shape) in the PIC
sheet and press CRTL + C.
- Right click on the cell
B5
in the main sheet and click on Paste Special-->Linked Picture
as shown below.
- Repeat for Cell
C5
and D5
. Your worksheet now looks like this.
- 我们现在已准备好基本设置。打开VBE并将以下代码粘贴到工作表代码区域中,我们就完成了!
Code:
Option Explicit
'More about Worksheet_Change at the below link
'https://stackoverflow.com/questions/13860894/why-ms-excel-crashes-and-closes-during-worksheet-change-sub-procedure/13861640#13861640
Private Sub Worksheet_Change(ByVal Target As Range)
'~~> Check if multiple cells were changed
If Target.Cells.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Range("B4:D4")) Is Nothing Then
Dim wsPic As Worksheet
Dim pic As Shape, txtShp As Shape, shp As Shape
Dim addr As String
Dim aCell As Range
'~~> Identify the shape below the changed cell
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Offset(1).Address Then
Set txtShp = shp
Exit For
End If
Next shp
Set wsPic = ThisWorkbook.Sheets("PIC")
'~~> Find the text in the PIC sheet
Set aCell = wsPic.Columns(1).Find(What:=Target.Value2, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> Identify the shape
If Not aCell Is Nothing Then
For Each shp In wsPic.Shapes
If shp.TopLeftCell.Address = aCell.Offset(, 1).Address Then
Set pic = shp
addr = aCell.Offset(, 1).Address
Exit For
End If
Next shp
End If
'~~> Add the formula to show the image
If Not pic Is Nothing And Not txtShp Is Nothing Then
txtShp.Select '<~~ Required to insert the formula
Selection.Formula = "=PIC!" & addr
Else
txtShp.Select
Selection.Formula = "=PIC!$B$2"
End If
Target.Select '<~~ Remove focus from the shape
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
行动中
样本文件
您可以从以下位置下载示例文件Here https://www.dropbox.com/s/nsnhg7keuxl0rc3/Image%20Pullup.xlsm?dl=0