VBA：如何检查特定单元格是否包含图像，然后删除图像（如果存在）

Question

在标题为Counter Party Select的工作表中，我想检查单元格D2是否包含想象。 如果单元格确实包含图像（图片），我想删除该图片。 我尝试使用的代码在Set thing = Sheets("Counter Party Select").Range("D2").Select 。

错误消息是Run-time error 4242. Object Required 。 我应该使用什么代码？

Sub Logo_Fill()

    Dim myImage As Shape
    Dim thing As Object
    Set thing = Sheets("Counter Party Select").Range("D2").Select
    
    If TypeName(thing) = "Picture" Then
        Set myImage = ActiveSheet.Shapes("Picture 1")
        myImage.Delete
    End If

End Sub

Answer 1

当你想要单元格 D2 的值时，你应该使用

Dim myImage As Shape
Dim thing As Variant
thing = Sheets("Counter Party Select").Range("D2").Value

Answer 2

从单元格中删除图片

• 以下是使用（调用） deletePictureFromCell过程的解决方案。
• deletePictureFromCell使用它们的地址，而不是您的（有效）解决方案中使用的单元格对象。

代码

Option Explicit

Sub Logo_Fill()
    
    Const wsName As String = "Counter Party Select"
    Const CellAddress As String = "D2"
    Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim pic As Picture
    
    deletePictureFromCell pic, ws, CellAddress

End Sub

Sub deletePictureFromCell(ByRef PictureObject As Picture, _
                          Optional Sheet As Worksheet, _
                          Optional ByVal CellAddress As String = "A1")
    
    If Sheet Is Nothing Then Set Sheet = ActiveSheet
    
    For Each PictureObject In Sheet.Pictures
        If PictureObject.TopLeftCell.Address(False, False) _
          = Replace(CellAddress, "$", "") Then
            PictureObject.Delete
            ' If only one picture per cell, this could increase efficiency:
            'Exit For ' No need to loop anymore.
        End If
    Next PictureObject
   
End Sub

你的代码

• 您可以使用With语句重写代码。
• 请注意点 ( . ) .Unprotect 、 .Pictures和.Range("D2") 。
• 没有必要在Intersect前面使用Application ，但最好记住它是Application object的方法，而不是Workbook object 的方法。

重构

Sub Logo_Fill2()

    Dim pic As Picture

    With Sheets("Counter Party Select")
        .Unprotect
        For Each pic In .Pictures
            If Not Intersect(pic.TopLeftCell, .Range("D2")) Is Nothing Then
                pic.Delete
            End If
        Next pic
    End With

End Sub

Answer 3

我想出了一种使用 for 循环执行此操作的方法：

Sub Logo_Fill()

    Dim pic As Picture

    Sheets("Counter Party Select").Unprotect
    
    For Each pic In Sheets("Counter Party Select").Pictures
        If Not Application.Intersect(pic.TopLeftCell, Range("D2")) Is Nothing Then
            pic.Delete
        End If
    
    Next pic

End Sub