excel - 从单元格中删除所有图像，除了 vba 中的最后一个

Question

我在单元格中有相同的图像，所以我想删除除最后一个之外的所有图像(只保留一个)。
我有下面的代码，但它只适用于一个单元格。我看到删除代码有问题。

Sub CellImageCheck()  '' Delete multiple images in cells
    Dim checkRange As Range
    Dim x As Shape
    Dim flag As Boolean
    'On Error Resume Next

Dim WorkRng As Range
Set WorkRng = Range("E1:E372")

        For Each x In ActiveSheet.Shapes
            m = Range(x.TopLeftCell.Address).Row
            Cells(m, 7).Value = Cells(m, 7).Value + 1 '' write image count from cell in respetice row in E column
        Next
        
        ''' Delete all images in cell except last
        For Each x In ActiveSheet.Shapes
        m = Range(x.TopLeftCell.Address).Row
        
            For Each Rng In WorkRng
                If Cells(m, 7).Value > 1 Then
                    Cells(m, 7).Value = Cells(m, 7).Value - 1
                    x.Delete
                End If
            Next
        Next
End Sub

Answer 1

您可以使用字典来跟踪哪些单元格已与形状关联，然后删除也与同一单元格关联的任何“额外”形状。

Sub CellImageCheck()  
    
    Dim i As Long, addr, dict As Object
    
    Set dict = CreateObject("scripting.dictionary")
    
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        With ActiveSheet.Shapes(i)
            addr = .TopLeftCell.Address(0, 0)
            If Not dict.exists(addr) Then
                dict.Add addr, True  'first shape over this cell
            Else
                .Delete              'already have a shape for this cell
            End If
        End With
    Next i
End Sub