0

我一直在编写的程序从工作簿中的各种来源读取信息，将信息重新排列到单独工作表上的几个紧凑表中，然后将这些表作为图像复制到单独的摘要表中。我把这个程序写成几个不同的子程序，由主程序调用。

当主程序运行时，它粘贴到摘要表中的图像具有正确的尺寸和位置，但它们是完全白色的。但是，当我运行负责复制这些图像的子例程时，它实际上成功地复制了正确的表。这是我用来复制和粘贴表格的代码，作为图像：

Sub ExtractToPresentation()

Call UnprotectAll

Application.DisplayAlerts = False

Application.CutCopyMode = False

startcell = Worksheets("Supplier Comparison").Cells(1, 1).Address
bottomcell = Worksheets("Supplier Comparison").Cells(21, 14).Address

Set copyrng = Worksheets("Supplier Comparison").Range(startcell, bottomcell) '.SpecialCells(xlCellTypeVisible)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(SupSt)

End With

子例程继续，但其余的是每个附加表的上述代码的变体：

startcell = Worksheets("Rating Criteria").Cells(1, 1).Address
bottomcell = Worksheets("Rating Criteria").Cells(12, 7).Address

Set copyrng = Worksheets("Rating Criteria").Range(startcell, bottomcell)
copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CritSt)

End With

startcell = Worksheets("Comments").Cells(1, 1).Address
bottomcell = Worksheets("Comments").Cells(4, 14).Address

Set copyrng = Worksheets("Comments").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CommSt)

End With

startcell = Worksheets("Component Table").Cells(1, 1).Address
bottomcell = Worksheets("Component Table").Cells(CompH, CompW).Address

Set copyrng = Worksheets("Component Table").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CompSt)

End With

Application.DisplayAlerts = False

Call ProtectAll

End Sub

以 St、H 和 W 结尾的变量在前面的程序中定义，该程序确定每个表的大小。我不知道为什么这个程序可以完美地独立运行，但在其他程序之后运行时会返回空白图像。

如果有人想查看我的代码的其他部分，请告诉我。这个程序有大约 500 行，我不想一次全部转储。

4

3 回答 3

1

application.screenupdating = true也尝试一下displayalert - true，看看它是否有效。

我在将对象从 excel 复制到 PPT 时遇到了同样的问题，当我制作screeupdating = true（默认）时，它开始工作:-)

斯沃鲁普

于 2015-10-09T06:49:28.287 回答
0

尝试

Range(*source*).Copy                           ' full source range

' asume you have a destination cell as a range
*destination*.Parent.Select                    ' select sheet
*destination*.Select                           ' select dest cell
*destination*.Parent.Pictures.Paste            ' paste

如果您需要调整图像大小，请使用

*sheet*.Shapes(x).Height
*sheet*.Shapes(x).Width

工作示例：

Sub Test()
    Set src = Sheets("Sheet1").Range("A1", "B4")
    Set dst = Sheets("Sheet2").[C5]
    src.Copy
    dst.Parent.Select
    dst.Select
    dst.Parent.Pictures.Paste
    src.Parent.Select
    src.Select
End Sub
于 2013-10-18T17:10:50.467 回答
0

我从几个文件中插入了 3000 多张图片，有时也会出现这个问题。我可以通过在插入和放置图片之后立即插入一个短暂的休息 [ Sleep(25) ] 和 [ DoEvents ] 来解决这个问题。无需屏幕更新...

于 2017-07-17T13:01:17.063 回答