Картинка в определенных клетках в диапазоне

Question

У меня следующий код для пометки ячеек смещения, если над выбранными ячейками есть изображение над ними. Код выполняется правильно и быстро для небольшого выбора. Однако, если выбор большой, он замедляется. Можно ли это оптимизировать? Есть ли способ перебрать только выбранные ячейки вместо перемещения всей коллекции фигур на листе? Код:

Я попытался следующий код с методом пересечения безуспешно:

Sub findCellsWithShapes()
Dim sh As Shape, isect, rng As Range, n As Integer
n = 1
    For Each sh In ActiveSheet.Shape
        Set isect = Application.Intersect(sh.TopLeftCell, Selection)
            If Not isect Is Nothing Then
               If sh.TopLeftCell.Address = Selection(n) Then
                  Selection(n).Offset(0, 30) = "Yes"
               End If
            Else
               If sh.TopLeftCell.Address = Selection(n) Then
                  Selection(n).Offset(0, 30) = "No"
               End If
            End If
                 If n < Selection.Cells.Count Then
                    n = n + 1
                 Else
                    Exit For
                 End If
     Next sh
End Sub

Answer 1

Попробуйте это:

Я просто удаляю некоторые ваши циклы, чтобы уменьшить вычисления.

Sub tagging2()
Dim rng As Range
Dim shp As Shape
Dim m As Long
Dim arr() As String
Dim Sample As String

m = 1
ReDim arr(ActiveSheet.Shapes.Count)

For Each shp In ActiveSheet.Shapes
    arr(m) = shp.TopLeftCell.Address
    m = m + 1
Next

For Each rng In Selection
    Sample = rng.Address
    For m = 1 to ActiveSheet.Shapes.Count
        If Sample = arr(m) Then
              rng.Offset(0, 30).Value = "Yes"
              Exit For
        End If
    Next m
    If IsEmpty(rng.Offset(0, 30)) Then rng.Offset(0, 30).Value = "No"
Next
End Sub

Я не могу сравнить с вашим исходным. Во всяком случае, я думаю, что пересечение должно быть быстрее. Как вы выбираете?

Надеюсь, это поможет