Excel VBA - 在 Worksheet_Change 事件上将图像插入工作表时出现问题答案

【问题标题】：Excel VBA - Issue when inserting image to worksheet on Worksheet_Change eventExcel VBA - 在 Worksheet_Change 事件上将图像插入工作表时出现问题
【发布时间】：2016-11-22 20:06:28
【问题描述】：

我有两列：

     A         B
1    Animal    Picture
2    Lion      (Lion picture)
3    Ant       (Ant picture)

当我在新单元格中输入动物名称时（比如说A4），公式完美运行：我在图片列中得到图片 (B)。

如果我删除 cloumn A 中的一个值（假设我删除了 Lion），那么 Lion 的图片就会被删除。

但是当我手动编辑而不删除A2 中的值时，一张新图片与最后一张图片上方的B2 重叠。当我删除 A2 值时，只会删除最新的图片。我必须再次删除空单元格A2 以删除单元格B2 中的剩余图片。

有没有办法解决这个问题？

这是我当前的Worksheet_Change 事件代码：

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row Mod 20 = 0 Then Exit Sub

    If Not IsEmpty(Target) Then '<--| if changed cell content is not empty
        With Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".png")
            .Top = Target.Offset(0, 2).Top
            .Left = Target.Offset(0, 1).Left
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = Target.Offset(0, 2).Height
            .ShapeRange.Width = Target.Offset(0, 2).Width
            .Name = Target.Address '<--| associate the picture to the edited cell via its address
        End With
    Else '<--| if cell content has been deleted
        Me.Shapes(Target.Address).Delete '<--| delete the picture whose name is associated to the cell via its address
    End If
    Target.Offset(1, 0).Select
son:
End Sub

【问题讨论】：

乍一看，也许您应该始终（并且在做任何事情之前）删除与您正在编辑的单元格相关的图片。然后，如果编辑的单元格值是有效的，则应插入相应的图片。这样就不可能有图像叠加。有时它可能是“愚蠢的”，因为如果您编辑单元格并设置相同的值，它将删除并插入相同的图片。为避免这种情况，请检查 stackoverflow.com/a/4668523/6671476 并验证旧值是否与新值不同 :)
罗宾的回答对你有帮助吗？

标签： vba excel

【解决方案1】：

我同意@RCaetano 的评论：

...也许您应该始终（在做任何事情之前）删除与您正在编辑的单元格相关的图片。

如果您遵循此建议，那么您将不会遇到图像重叠的问题。如果A2 包含“Lion”；如果您手动编辑单元格并重新输入“Lion”，那么您将面临删除和重新插入相同图像的少量开销 - 但这是比您目前更好的结果。

Worksheet_Change 代码可以是：

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son

    Application.ScreenUpdating = False
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row Mod 20 = 0 Then Exit Sub

    'remove the picture
    Dim shp As Shape
    For Each shp In Me.Shapes
        If shp.Name = Target.Address Then
            Me.Shapes(Target.Address).Delete
            Exit For
        End If
    Next

    'add a picture of the text that was entered
    If Not IsEmpty(Target) Then '<--| if changed cell content is not empty
        With Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".png")
            .Top = Target.Offset(0, 2).Top
            .Left = Target.Offset(0, 1).Left
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = Target.Offset(0, 2).Height
            .ShapeRange.Width = Target.Offset(0, 2).Width
            .Name = Target.Address '<--| associate the picture to the edited cell via its address
        End With
    End If
    Target.Offset(1, 0).Select
    Application.ScreenUpdating = True

son:
    Application.ScreenUpdating = True
End Sub

【讨论】：