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

Information not formateed此图显示了信息的组织方式（由于与工作相关的信息，我更改了值）

Formatted Information此图显示了我如何格式化信息，并显示了图像的空白。

任何想法或建议都将不胜感激！

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

使用VBA将多个图像移动到另一个工作表-新位置

1 个答案: