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

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

複数のファイルから 3,000 枚以上の写真を挿入していますが、この問題が発生することもあります。画像の挿入と配置の直後に短い休憩 [ Sleep(25) ] に続いて [ DoEvents ] を挿入することで問題を解決できました。ScreenUpdating は必要ありません...

于 2017-07-17T13:01:17.063 に答える