[[20140903100028]]　『画像コピペの高速化』（たま）　ページの最後に飛ぶ

『画像コピペの高速化』（たま）

こんにちは。
マクロの件で、質問をお願いします。

ファイルに26個シートがあって、先頭から25シート目までのシート名は
01，02・・・25という風に番号をふっています。
最後のシートは画像貼付け用で「画像」というシート名にしています。
01～25のシートのB12からIH247を選択して図として画像シートに順番に
貼り付けるマクロを作成したのですが、処理時間が50秒ほどかかってしまいます。
しかもマクロ実行後はファイルサイズがかなり大きくなってしまいます。
画面の更新を停止すると画像が正しく表示されません。
（真っ白な画像が貼り付けられます。）
処理時間を短縮でき、かつファイルサイズが小さくなるのが理想です。
出来れば１シートに付き１秒弱くらいで処理ができればうれしいです。
すみません、どうぞよろしくお願いいたします。

ちなみに選択範囲のB12からIH247はセルにそれぞれ数値が入っていて
その数値ごとに色わけをしています。

以下が私が作成したマクロコードです。
添削の程、よろしくお願いいたします。

Option Explicit

Sub Sample()
Dim myWeekday As Integer
Dim myMsg As String, myStyle As String, Answer As String
Dim MaxRow As Long
Dim MaxCol As Long
Dim Grow As Integer
Dim i As Integer
Const myHeight = 150 '行の高さ。0-409を指定。
Const myWidth = 25 '列の幅。0 - 255を指定。

With Worksheets("画像")

 .Activate
 ActiveWindow.Zoom = 100
 .DrawingObjects.Delete                           
 .Cells.Clear
 .Rows(1).Delete
 .Rows.AutoFit                                                   
 .Range("A1").Select
 .Rows("1:6").RowHeight = myHeight
 .Columns("A:E").ColumnWidth = myWidth
End With

With Worksheets(1)

  .Activate
  MaxRow = .Range("A" & Rows.Count).End(xlUp).Row
  Grow = .Range("A1").End(xlDown).Row
  MaxCol = .Cells(Grow + 2, 2).End(xlToRight).Column
End With

For i = 1 To 25

'＜指定セル範囲をクリップボードへピクチャ (画像)としてコピーします。＞

 With Worksheets(i)
   .Activate
   .Range(Cells(Grow + 4, 2), Cells(MaxRow, MaxCol)) _
                    .CopyPicture xlScreen, xlBitmap
 End With

With Worksheets("画像")

  .Activate
'＜新規シートに貼り付けします。＞
Select Case Worksheets(i).Name
 Case "01": ActiveSheet.Paste Destination:=Worksheets("画像").Range("A1")
 Case "02": ActiveSheet.Paste Destination:=Worksheets("画像").Range("B1")
 Case "03": ActiveSheet.Paste Destination:=Worksheets("画像").Range("C1")
 Case "04": ActiveSheet.Paste Destination:=Worksheets("画像").Range("D1")
 Case "05": ActiveSheet.Paste Destination:=Worksheets("画像").Range("E1")
 Case "06": ActiveSheet.Paste Destination:=Worksheets("画像").Range("A2")
 Case "07": ActiveSheet.Paste Destination:=Worksheets("画像").Range("B2")
 Case "08": ActiveSheet.Paste Destination:=Worksheets("画像").Range("C2")
 Case "09": ActiveSheet.Paste Destination:=Worksheets("画像").Range("D2")
 Case "10": ActiveSheet.Paste Destination:=Worksheets("画像").Range("E2")
 Case "11": ActiveSheet.Paste Destination:=Worksheets("画像").Range("A3")
 Case "12": ActiveSheet.Paste Destination:=Worksheets("画像").Range("B3")
 Case "13": ActiveSheet.Paste Destination:=Worksheets("画像").Range("C3")
 Case "14": ActiveSheet.Paste Destination:=Worksheets("画像").Range("D3")
 Case "15": ActiveSheet.Paste Destination:=Worksheets("画像").Range("E3")
 Case "16": ActiveSheet.Paste Destination:=Worksheets("画像").Range("A4")
 Case "17": ActiveSheet.Paste Destination:=Worksheets("画像").Range("B4")
 Case "18": ActiveSheet.Paste Destination:=Worksheets("画像").Range("C4")
 Case "19": ActiveSheet.Paste Destination:=Worksheets("画像").Range("D4")
 Case "20": ActiveSheet.Paste Destination:=Worksheets("画像").Range("E4")
 Case "21": ActiveSheet.Paste Destination:=Worksheets("画像").Range("A5")
 Case "22": ActiveSheet.Paste Destination:=Worksheets("画像").Range("B5")
 Case "23": ActiveSheet.Paste Destination:=Worksheets("画像").Range("C5")
 Case "24": ActiveSheet.Paste Destination:=Worksheets("画像").Range("D5")
 Case "25": ActiveSheet.Paste Destination:=Worksheets("画像").Range("E5")
End Select

  With .Shapes(i)
    .LockAspectRatio = msoTrue              '縦横比を固定する。
    .ScaleHeight 1, msoTrue                 '画像の幅を１に設定する
    .ScaleWidth 1, msoTrue                  '画像の高さを１に設定する。
    .Width = ActiveSheet.Cells(1, 1).Width  '画像の幅をセルの幅に合わせる。
  End With

If i = 1 Then .Rows("1:5").RowHeight = .Shapes(i).Height

End With
Next i

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

動かしてはいませんが、範囲をクリップボードにコピペし、これを貼るのは遅いと思います。
画像自体と周辺の文字を、別々に貼り付けるような工夫を考えてみてはいかがでしょう？

速くなるかどうかは、画像オブジェクトを他シートにコピーするところだけ試してみるとか。
（???） 2014/09/03(水) 16:33

 .Activate
 .Select
 をやめるだけで結構早くなると思います。
（めいぷる） 2014/09/03(水) 16:58

コメント返信：

[ 一覧(最新更新順) ]

[[20140903100028]] 『画像コピペの高速化』（たま） ページの最後に飛ぶ

[[20140903100028]]　『画像コピペの高速化』（たま）　ページの最後に飛ぶ