コピー貼り付けのマクロの処理時間の早い方法を教えてください。

質問

ある表の中から部分的にセルを指定して抜き出して、
別の表を作成しています。

コピーする範囲のセルが連続して繋がっていないので、
セルを一つづつ指定してコピーして貼り付ける動作をマクロの自動記録で登録しました。
コピー貼り付けの回数が１００セル分ほどあるので、処理時間が遅いです。
目で見て順番にデータがコピーされて行くのが分かるくらいです。

この動作をもっと速くするマクロを教えてください。

実際の表ではコピー元（sheet1)のＡ５→コピー先（sheet2)Ｃ１、
以下同じくコピー元は全て（sheet1)でコピー先は（sheet2)です。

Ａ８→Ｃ２、Ａ１１→Ｃ３、Ａ１４→Ｃ４、Ａ１７→Ｃ５，・・・・
Ｂ２→Ｄ１、Ｂ１２→Ｄ２、Ｂ２２→Ｄ３、Ｂ３２→Ｄ４，・・・・
このような感じでコピーします。

*コピー元のsheet1の指定セルは毎回同じ場所です。
コピー先も毎回同じセルです。

宜しくお願いします。

回答No.4

fujillin · ベストアンサー

PCの性能にもよるのでスピードは何ともいえませんが、必要外の命令を省くこと、画面のアップデートをさせないことなどでスピードアップが図れます。100回のコピーでそれほど時間がかかるとも思えません。（単純コピーで試してみましたが、こちらのマシンでは10,000回で約6秒でした）

さて、コピーには規則性があるものとして、（A列は3行おき、B列は10行おきと仮定）終りの行はともに50行、コピー先はC、D列とも1行目から記入されていくものとすれば、以下のようなものでいかがでしょうか？
（仮定したシート名、行番号などは、適宜修正してください。）

Sub test()
　Dim ss As Worksheet, ds As Worksheet
　Dim i As Long, r As Long
　Set ss = Worksheets("Sheet1") 　　'←コピー元のシート
　Set ds = Worksheets("Sheet2") 　　'←コピー先のシート

　　'//A列のコピー（スタート行番号、最大行番号、間隔）
　r = 1
　For i = 5 To 50 Step 3
　　ds.Cells(r, 3).Value = ss.Cells(i, 1).Value
　　r = r + 1
　Next i
　　'//B列のコピー（スタート行番号、最大行番号、間隔）
　r = 1
　For i = 2 To 50 Step 10
　　ds.Cells(r, 4).Value = ss.Cells(i, 2).Value
　　r = r + 1
　Next i
End Sub

補足

回答ありがとうございます。
この方法もかなり早いですね。
これのアレンジで形式を選択して貼り付け（値のみ）の場合はどのように変更したら良いですか？

回答No.5

fujillin

#4です。

＞選択して貼り付け（値のみ）の場合はどのように変更したら良いですか？
実は、もともと意図的に値のみ貼り付けにしてあります。
（dest.value = sorce.value　という記述なので値だけ入力している。）

たいていの場合セルのコピーをする時には、罫線をコピーしたくない場合が多いので、勝手にそのように考えて作成しました。
それなので、逆に言えば、式をそのままコピーしたい場合や、文字の色、リンクなども、このままだとコピーされません。
ご質問文から想像するに、値だけコピーできれば（できるほうが）意図に合うであろうと判断させていただきました。

お礼

試したデータも数値だけのデータだったので気付きませんでした。
ありがとうございました。

回答No.3

pkh4989

こんにちは。
ワークテーブルを利用しましょう。
以下のようにコピー元とコピー先の範囲をワークへ設定してから
ワークへ移動するように試してみてください。Rangeは必ず "A1: から
Sub Copy()
　　Dim wVal　　　　As Variant
　　Dim wVal2　　　 As Variant
　　'
　　'コピー元
　　wVal = Worksheets("Sheet1").Range("A1:Z100")　 '→wVal(100,26)の2次元テーブルになる
　　'→wVal(100,26)の2次元テーブルにRange("A1:Z100")の内容が設定される
　　'コピー先
　　wVal2 = Worksheets("Sheet2").Range("A1:Z100")
　　'
　　'A8→C2
　　wVal2(2, 3) = wVal(8, 1)
　　'A11→C3
　　wVal2(3, 3) = wVal(11, 1)
　　'A14→C4
　　wVal2(4, 3) = wVal(14, 1)
　　'A17→C5
　　wVal2(5, 3) = wVal(17, 1)
　　'
　　'↓
　　'ワークテーブルの内容をシートへ設定
　　Worksheets("Sheet2").Range("A1:Z100") = wVal2
　　'又は
　　Worksheets("Sheet2").Range("A1").Resize(100, 26) = wVal2
End Sub

お礼

回答ありがとうございます。
速いですね～。
勉強になります。

回答No.2

hana-hana3

単純なコピーならこれ。
Sub test1()
Sheets("Sheet1").Range("A8,A11,A14,A17,A20,A23,A26").Copy Sheets("Sheet2").Range("C1")
End Sub

法則があるならＶＢＡらしくこれ。
Sub test2()
Dim i As Long
For i = 0 To 30
With Sheets("Sheet1")
.Range("A8").Offset(i * 3).Copy Sheets("Sheet2").Range("C1").Offset(i)
.Range("B2").Offset(i * 10).Copy Sheets("Sheet2").Range("D1").Offset(i)
End With
Next
End Sub

お礼

単純なコピーが意外と速かったです。
ありがとうございました。

補足

回答ありがとうございます。
法則がある場合で、コピー元の表の５０行目までだけを対象とする場合はどうすれば良いのですか？（５１行目以降も入力されたセルがあるが、それはコピーしない）

回答No.1

n-jun

コードの提示がないので憶測です。

Application.ScreenUpdating = False
'～処理～
Application.ScreenUpdating = True
としてますか。

お礼

回答ありがとうございました。
参考にさせていただきます。