将图片复制到目标工作簿中的相应单元格

Question

我正在尝试将一些传播sheet编译到目标工作簿中。

我无法将图片导入新工作簿。

我研究了数组和集合，但我的实现有很多错误，我去掉了代码。

我添加了Application.CopyObjectsWithCells = True但是对图片没有影响

这是有效的代码。我可以添加什么来把图片带过来？

Private Sub btnStitchData_Click()
Dim dsh As Worksheet
Dim sh As Worksheet
Dim wb As Workbook
Dim n As Long

Dim blnCountingInit As Boolean

Dim fso As New FileSystemObject
Dim fo As Folder
Dim x As File

Application.DisplayAlerts = False
Application.CopyObjectsWithCells = True

Set fo = fso.GetFolder("C:\Users\PCCSa\Documents\PCC\Workbooks\Compiler")
Set dsh = ThisWorkbook.Sheets("Compile Test")

For Each x In fo.Files
    Set wb = Workbooks.Open(x.Path)
    Set sh = wb.Sheets("Invoice")
    
    If blnCountingInit = False Then
        n = dsh.Range("A1" & Application.Rows.Count).End(xlUp).Row
        sh.UsedRange.Copy
        dsh.Range("A1" & n).PasteSpecial xlPasteAllUsingSourceTheme
        blnCountingInit = True

    Else
        sh.Range("A15").Select
        sh.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        sh.UsedRange.Copy
        dsh.Range("A1" & n).PasteSpecial xlPasteAll
    End If
    
    wb.Close False

Next

End Sub

我的目标是复制第一个跨页sheet中的单元格，粘贴它，然后从指定行 (A15) 开始复制所有其他 sheet。

此sheet中的图片(shapes/objects?)需要粘贴到源传播sheets中的相应单元格中。

Answer 1

下面是一个子过程，您可以将其包含在代码中以将图片从一个范围复制到另一个范围并遵守源范围中图片的相对位置。

此宏循环遍历源范围（第一个参数）所在 sheet 中的所有图片，并检查每张图片的左上角是否在该范围内。这并不完美，因为您可能想要排除不完全适合该范围的图片（见下图），但我认为这可能足以满足您的用例。

例如，如果源图片范围是使用的范围：

宏随后将粘贴图片并相对于您为第二个参数提供的单元格重新定位，以确保图片在粘贴后具有相同的相对位置。

这是子程序的代码：

Sub CopyPicturesInsideRange(ByRef SrcPictRange As Range, ByRef DestTopLeftCell As Range)

    Dim shp As Shape
    For Each shp In SrcPictRange.Parent.Shapes

        If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then

            If SrcPictRange.Top <= shp.Top And shp.Top <= SrcPictRange.Top + SrcPictRange.Height Then

                If SrcPictRange.Left <= shp.Left And shp.Left <= SrcPictRange.Left + SrcPictRange.Width Then

                    shp.Copy

                    Dim dws As Worksheet
                    Set dws = DestTopLeftCell.Parent

                    dws.Parent.Activate
                    dws.Activate
                    dws.Paste

                    Dim NewShape As Picture
                    Set NewShape = Selection

                    Dim OriginalTopOffset As Double, OriginalLeftOffset As Double
                    OriginalTopOffset = shp.Top - SrcPictRange.Top
                    OriginalLeftOffset = shp.Left - SrcPictRange.Left

                    NewShape.Top = DestTopLeftCell.Top + OriginalTopOffset
                    NewShape.Left = DestTopLeftCell.Left + OriginalLeftOffset

                End If

            End If

        End If
    Next shp
End Sub

因此，要将其包含在您的代码中，您只需将现有的 If 语句替换为如下内容：

    If blnCountingInit = False Then
        n = dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
        sh.UsedRange.Copy
        dsh.Range("A" & n + 1).PasteSpecial xlPasteAllUsingSourceTheme

        CopyPicturesInsideRange sh.UsedRange, dsh.Range("A" & n + 1)

        blnCountingInit = True

    Else
        n = dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
        sh.Range(sh.Range("A15"), sh.Cells.SpecialCells(xlLastCell)).Copy
        dsh.Range("A" & n + 1).PasteSpecial xlPasteAll

        CopyPicturesInsideRange sh.Range(sh.Range("A15"), sh.Cells.SpecialCells(xlLastCell)), dsh.Range("A" & n + 1)

    End If

将图片复制到目标工作簿中的相应单元格

Copying pictures to corresponding cell in destination workbook

excel

vba

copy-paste

range