Как ускорить копирование (ВПР) картинок в Excel (VBA)?

Question

[DS28]

На первом листе есть 100-1500 строк; в 15 столбце (O) записаны имена, которые повторяются.
На втором листе именам в соответствие поставлены картинки одинакового размера и формата, всего 30-40 штук.
Цель - подтягивать картинки в первую таблицу (она будет обновляться вставкой данных извне)

Есть код, который на малых выборках работает, но подвисает на полных.
Есть идеи как ускорить?

Код

Sub push()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
    Dim Row1 As Integer, Row2 As Integer, i As Integer
    Dim sh1 As Worksheet, sh2 As Worksheet
    
    Set sh1 = Sheets("Лист1")
    Set sh2 = Sheets("Лист2")
    Row1 = sh1.Cells(Rows.Count, 15).End(xlUp).Row
    Row2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 8 To Row1
        If sh1.Cells(i, 15).Value > 0 Then
            sh2.Range("A2:A" & Row2).Find(what:=sh1.Cells(i, 15).Value, LookIn:=xlValues).Offset(0, 1).Copy
            sh1.Activate
            sh1.Cells(i, 16).Select
            ActiveSheet.Pictures.Paste(Link:=True).Select
        End If
        Application.CutCopyMode = False
    Next i
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Может есть более эффективный способ подтягивать картинки? Из папки или ещё как?
Цель: собирать pdf с картинками на основе данных из первой таблицы.

Comments

[h8nor]

Вы хотите загружать картинки в книгу и быстро? Забудьте. Картинки всегда хранят отдельно.

[DS28]

Дѣаволъ, картинки уже в книге.
Я хочу их по книге копировать, чтобы потом собрать pdf красивый.

[h8nor]

Попробуйте поискать решение здесь. ИМХО, зря вы затеяли компоновку картинок в Excel.

[DS28]

Дѣаволъ,

зря вы затеяли компоновку картинок в Excel

Есть альтернативы?
Я готов рассмотреть любое решение - научиться не проблема.

Answer 1

[h8nor]

У объекта коллекции Sheets.Shapes.Item(1) есть свойство Left и Top, если второе задаётся значением высоты строки, то первое зависит от множества других параметров. Картинка находится не в ячейке, как это кажется на первый взгляд. Поэтому лучше сразу задавать рисунку имя Shapes.Item(1).Name.

Уберите методы Activate и Select, - макрос будет работать быстрее. Например, вот так:

sh2.Shapes.Item(1).Copy
sh1.Pictures.Paste

ЗЫ, в подобных задачах полезно пользоваться отладчиком: View -> Locals Window

Comments

[DS28]

Попробую

[DS28]

Добрался до задачи - попробовал.
Решение работает - скорость действительно выросла в разы (быстрее 10 секунд, а до этого даже за 10 минут не обрабатывал)

If sh1.Cells(i, 15).Value = sh2.Shapes.Item(k).Name Then
    sh2.Shapes.Item(k).Copy
    sh1.Range(Cells(i, 16), Cells(i, 16)).PasteSpecial
End If

Правда пришлось повозится с соответствием номера Shapes.Item и его именем, но у меня всего 28 картинок - поэтому ок.