Question

我有两栏

A         B

Cat
Lion

图片位于c:\pictures文件夹中，格式为png。我写过这样的代码

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 4).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 2).Width
Target.Offset(1, 0).Select
son:

End Sub

该公式运作正常。但是当我删除A2或A3的值时，相应的picutres没有被删除。当我再次在A2和A3中写入项目时，图片会添加上面的旧图片。

如果单元格A2和A3的值为空，有没有办法删除图片？

Answer 1

已修改以在添加/删除图片之前处理图片缺失/存在

您可以使用父单元格地址命名图片，以便在删除某些父单元格内容后很容易引用它们：

Private Sub Worksheet_Change(ByVal target As Range)
    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
        If Not IsPicture(target) Then '<--| if there's not a picture whose name matches the target address
            With Pictures.Insert("C:\Users\chojwa\Desktop\a\UT\VARIE\software\VBA programming\Forum\Stack Overflow\images" & "\" & target.Value & ".bmp") '<--| insert it
                .Top = target.Offset(0, 2).Top
                .Left = target.Offset(0, 4).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
    Else '<--| if cell content has been deleted
        If IsPicture(target) Then Me.Shapes(target.Address).Delete '<--| delete the picture whose name is associated to the cell via its address, if any
    End If
    target.Offset(1, 0).Select
son:
End Sub

Function IsPicture(target As Range) As Boolean
    On Error Resume Next
    IsPicture = Not Shapes(target.Address) Is Nothing
    On Error GoTo 0
End Function

如何根据单元格值

1 个答案: