Перемещение нескольких изображений на другой лист с помощью VBA - новое местоположение

Question

Я создаю новый лист с целью реорганизации информации на другом листе.Мне удалось переместить всю другую информацию на другой лист в необходимом формате, но я не могу переместить изображения / изображения деталей.

Я пытался использовать код, показанный ниже, но ссылаясь на ячейку,изображения в, но это не копирует.Я провел небольшое исследование и выяснил, существует ли простой способ перемещения изображений, просто вставляя ячейки с помощью VBA, и он, похоже, не работает.Я также смотрю на попытки переименовать все фигуры, но безуспешно.

'find the last row of values
Worksheets("Eyelets").Activate

LastRow = Cells.Find("*", SearchOrder:=xlByRows, 
SearchDirection:=xlPrevious).Row + 3

Worksheets("Plot").Activate

'1st column of values
For i = 2 To LastRow Step 4

Count = Count + 1

x = i + Count

'Store all variables in the row
RDPNHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 0)
FDPNHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 1)
WRHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 4)
MatHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 9)
DiamHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 5).Value



'Move All Part Numbers to next sheet.
Worksheets("Plot").Range("A1").Offset(x - 2, 0) = RDPNText & RDPNHold
Worksheets("Plot").Range("A1").Offset(x - 1, 0) = FDPNText & FDPNHold
Worksheets("Plot").Range("A1").Offset(x, 0) = WRText & WRHold
Worksheets("Plot").Range("A1").Offset(x + 1, 0) = MatText & MatHold & DiamText & DiamHold


'Bold Specific parts of the cells
Worksheets("Plot").Range("A1").Offset(x - 2, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x - 1, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x + 1, 0).Characters(Len(lngIDStart), 4).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x + 1, 0).Characters(Len(lngIDStart) + 13, 5).Font.Bold = True

Next i

Информация не отформатирована Это изображение показывает, как информация уже организована (я изменил значения из-за связанной с работой информации)

Форматированная информация Это изображение показывает, как я пытаюсь отформатировать информацию, и, как показано, пустое пространство для изображений.

Любые идеи или предложения приветствуются!

Answer 1

Вот отправная точка:

Sub Tester()

    Dim shtSource As Worksheet, shtDest As Worksheet
    '....

    Set shtSource = Worksheets("Eyelets")
    Set shtDest = Worksheets("Plots")

    '....

    If CopyPicFromCell(shtSource.Range("A1").Offset(i - 1, 2)) Then
        'copied the picture, so paste to shtDest
        shtDest.Paste
        With shtDest.Shapes(shtDest.Shapes.Count)
            .Top = shtDest.Range("A1").Offset(0, 1).Top
            .Left = shtDest.Range("A1").Offset(0, 1).Left
        End With
    End If


End Sub



'see if there's a shape to be copied from a given cell
'  return True if one was found
Function CopyPicFromCell(c As Range)
    Const MARGIN As Long = 10 '<< how far the picture can be out of place
    Dim shp As Shape
    For Each shp In c.Parent.Shapes
        'check the TopLeftCell and the shape's position
        If shp.TopLeftCell.Address = c.Address Or _
            (Abs(shp.Left - c.Left) < MARGIN And Abs(shp.Top - c.Top) < MARGIN) Then
            shp.Copy
            CopyPicFromCell = True
            Exit For '<< done checking
        End If
    Next shp
End Function