VBA 重たいためコード改善お願いします

質問

ＶＢＡ歴３か月の学習者です。

セルに入力された行数をもとに、セル範囲を決め、シートＸＹにコピペをするコードを作りました。
コード自体は、思い通りに動いていますが、１０００回程度のループ処理を考えており、すべて終わるのに１時間程度かかってしまっています。

よろしければ、下記コード内で、時間を短縮できる編集のアドバイスをお願いいたします。

Sub test()

Dim i, LastR, TopR, BottomR, myRow As Long
Dim SheetD, SheetX, SheetY, SheetSu, mySheet As Worksheet
Dim ColumnF, ColumnL, n As String
Dim ResultRange As Range
Application.ScreenUpdating = False
Set SheetD = Sheets("D")
Set SheetX = Sheets("X")
Set SheetY = Sheets("Y")
Set SheetSu = Sheets("Sum")
Set ResultRange = SheetSu.Range("Z6:BT6")
ColumnF = "A"
ColumnL = "M"
LastR = SheetD.Range(ColumnF & Rows.Count).End(xlUp).Row
TopR = 2

i = 2
Do Until SheetD.Cells(i, "X") = "" And SheetD.Cells(i, "Y") = ""
If SheetD.Cells(i, "X") = "" Or SheetD.Cells(i, "Y") = "" Then
i = i + 1
Else
With SheetD
TopR = .Cells(i, "X").Value
BottomR = .Range("B" & TopR).End(xlDown).Row
.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
End With
With SheetX
.Columns(ColumnF & ":" & ColumnL).ClearContents
.Range("B1").PasteSpecial Paste:=xlPasteValues
End With
With SheetD
TopR = .Cells(i, "Y").Value
BottomR = .Range("B" & TopR).End(xlDown).Row
.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
End With
With SheetY
.Columns(ColumnF & ":" & ColumnL).ClearContents
.Range("B1").PasteSpecial Paste:=xlPasteValues
End With
ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value
i = i + 1
End If
Loop

Application.CutCopyMode = False
SheetX.Columns(ColumnF & ":" & ColumnL).ClearContents
SheetY.Columns(ColumnF & ":" & ColumnL).ClearContents
Application.ScreenUpdating = True
MsgBox "Finish"

End Sub

回答No.4

kagakusuki

>自動計算、手動計算のon/off
>でだいぶん改善されました。もう一度、ワークシート関数の効率化も考えてまいります。

　いや、前回の回答で申し上げた事は、データを貼り付ける度に自動計算をONにするのではなく、自動計算はOFFにしたままで、「それまではワークシート関数で行っていた処理」と同じ結果を出す処理をVBA上で行った方が宜しいのではないかという事です。
　質問者様がどの様なワークシート関数をどのセルに設定されているのかという情報を開示して頂ければ、もっと良い効率化の案に関する回答が、私の他からも得られる可能性が高いと思います。

　それに、Dシートのデータを一々、(Sheet△.Range(○○).Value=Sheet◇.Range(○○).Value等を使って)XシートやYシートにコピーせずとも、Dシート上に存在しているデータを直接参照し、そのデータに基づいて行った処理の結果を、ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5)の範囲に直接書き込む様にされれば、

.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
.Columns(ColumnF & ":" & ColumnL).ClearContents
.Range("B1").PasteSpecial Paste:=xlPasteValues

や

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value
SheetX.Columns(ColumnF & ":" & ColumnL).ClearContents
SheetY.Columns(ColumnF & ":" & ColumnL).ClearContents

などといった無駄なコピーや消去が行われない分、効率的な処理が行える筈です。

>offsetの引数に関しましては、変数等はありませんが、現行で、Ｚ列の最終行を取得して、-5（resultrangeより上の見出し行数分）を差し引いたもので、今のところうまくいっているのですが、なぜでしょうか。
>順番にoffset(1) offset(2)・・・と取ってきてくれます。

　Sumシート上のセルに対する入力や消去は、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

の所でしか行われていないのですから、Do～Loopの1巡目で

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5)

の所に値が入力されれば、それ以降は

Cells(Rows.Count, "Z").End(xlUp).Row

の値は変化しない筈ですので、

>順番にoffset(1) offset(2)・・・と取ってきてくれます。

という事にはならないと思うのですが？
(これが

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5)

ではなく、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row + 5)

であったのなら、Zの最終行が5ずつ増えて行きますので、順番に表示を増やす事も出来るかと思います)
　もし例えば、Z7:Z20の範囲にワークシート関数が入力されていて、その関数の結果によってZ7:Z10の範囲に何らかの値が表示され、Z11:Z20の範囲には何も表示されていない状態であったとしましても、実際にはZ20に関数が入力されている以上、

Cells(Rows.Count, "Z").End(xlUp)

の結果は、Z10ではなく、Z20になりますので、

Cells(Rows.Count, "Z").End(xlUp).Row -5

の値は15という事になり、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5)

が示しているセルはZ15セルという事になるのですから、そのZ15セルに値を入力した処で、Z列の最終行のセルは相変わらずZ20のままで変化しませんから、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

の処理でResultRangeの値が入力されるのは、毎回必ずZ15:BT15のままで変化しません。

回答No.3

kagakusuki

>行数を決定→選択するセル範囲の決定→シートＸＹに貼り付け→resultrangeにその結果が返る→resultrangeの下に順番に貼り付け→行数の項目が空白になるまでループ
>というような仕組みです。

との事ですが、それはresultrangeにワークシート関数が入力されていて、その結果を取り出して使っているという事なのでしょうか？
　しかしながら、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

という構文の中には、行番号を指定する部分にはi等の変数が含まれておりませんので、

>resultrangeの下に順番に貼り付け

という事にはならない筈です。
　それに、常に同じ行に対してのみ値の貼り付けが行われる事になりますから、得られる結果は

SheetD.Cells(i, "X") = "" And SheetD.Cells(i, "Y") = ""

となる直前の行(データが存在する最終行)のデータをXシートとYシートに貼り付けた際の、ResultRangeの値が反映されるだけで、Dシートに存在している「最終行以外の行」のデータは一切反映されない様に思えるのですが、一体何をしたいのでしょうか？

　兎に角、

>１０００回程度のループ

くらいで、

>すべて終わるのに１時間程度かかってしまっています

というのは少々時間が掛かり過ぎですので、おそらくXシートの値を消去した時、Xシートに値を貼り付けた時、Yシートの値を消去した時、Yシートに値を貼り付けた時、のそれぞれにおいて毎回(ワークシート関数の)再計算が行われる事も、重くなっている原因の1つではないかと思います。
　ですから、最初の辺りの所に

Application.Calculation = xlCalculationManual

を入れて、自動的に計算されないようにした上で、ワークシート関数を使ってやっていた処理もVBA上で行う様にされた方が宜しいのではないかと思います。(因みに、自動計算モードに戻す場合は　Application.Calculation = xlCalculationAutomatic　という構文になります)
　その際には、Xシートに値を貼り付けと、Yシートに値を貼り付けの双方が済んでから、ワークシート関数でやっていたのと同じ処理をVBA上で行い、それが済んでからXシートの値を消去と、Yシートの値を消去を行う様にされた方が良いと思います。
　又、もしもXシートやYシートに前回貼り付けた値を消去しなくても悪影響が無い様であれば、それらの消去はDo～Loopの処理が済んでからまとめて行う様にされた方が処理が速くなります。

お礼

ありがとうございます。的確でわかりやすいご回答に感激しております。
copy.pasteの削除
自動計算、手動計算のon/off
でだいぶん改善されました。もう一度、ワークシート関数の効率化も考えてまいります。

>>前回貼り付けた値を消去しなくても悪影響が無い様であれば、、、、
こちらは、行数が定まっていないため、残念ながら使うことができませんm(__)m

>>resultrangeにワークシート関数が入力されていて、その結果を取り出して使っているという事なのでしょうか？
その通りでございます。説明が下手で申し訳ありません。

>>Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5)
offsetの引数に関しましては、変数等はありませんが、現行で、Ｚ列の最終行を取得して、-5（resultrangeより上の見出し行数分）を差し引いたもので、今のところうまくいっているのですが、なぜでしょうか。
順番にoffset(1) offset(2)・・・と取ってきてくれます。
コードの書き方が、変なのかもしれませんm(__)m

大変勉強になりました。ありがとうございました。

回答No.2

kagakusuki

XシートやYシートのB列に値のみ貼り付けを何度行った処で、最後の

SheetX.Columns(ColumnF & ":" & ColumnL).ClearContents
SheetY.Columns(ColumnF & ":" & ColumnL).ClearContents

の所でXシートとYシートのA列～M列に入力された値は全て消去されるのですから、

With SheetD
TopR = .Cells(i, "X").Value
BottomR = .Range("B" & TopR).End(xlDown).Row
.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
End With
With SheetX
.Columns(ColumnF & ":" & ColumnL).ClearContents
.Range("B1").PasteSpecial Paste:=xlPasteValues
End With
With SheetD
TopR = .Cells(i, "Y").Value
BottomR = .Range("B" & TopR).End(xlDown).Row
.Range(ColumnF & TopR & ":" & ColumnL & BottomR).Copy
End With
With SheetY
.Columns(ColumnF & ":" & ColumnL).ClearContents
.Range("B1").PasteSpecial Paste:=xlPasteValues
End With

の部分で行われている事は全て無駄です。
　又、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

の所で行われている事は、iの値が幾つであっても常に同じ処理しか行われないのですから、Do～Loopの中に入れる意味がありませんし、むしろDo～Loopの中に入れる事によって処理が遅くなるのですから入れない方が良い事になります。
　従って、質問者様のVBAのマクロと同じ結果を得るためだけならば、Do～Loop自体、用いる必要が無い事になります。
　後、Cells(Rows.Count, "Z").End(xlUp).Rowとしたのでは、「DシートのC列においてデータが存在している最終行のセルの行番号」ではなく、「現在開いているシートのC列においてデータが存在している最終行のセルの行番号」になってしまい、

ResultRange.Offset(ActiveSheet.Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

という事になってしまいますから、

ResultRange.Offset(Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

という部分は

ResultRange.Offset(SheetSu.Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value

の間違いではなでしょうか？
　それにもかかわらず、

>コード自体は、思い通りに動いていますが

と仰っておられますが、思った通りに動いているというのは本当なのですか？

　従って、改善したコードは以下の様なものとなります。

Sub test()

Dim SheetD, SheetX, SheetY, SheetSu As Worksheet
Dim ClearColumns As String
Dim ResultRange As Range

Set SheetD = Sheets("D")
Set SheetX = Sheets("X")
Set SheetY = Sheets("Y")
Set SheetSu = Sheets("Sum")
Set ResultRange = SheetSu.Range("Z6:BT6")
ClearColumns = "A:M"

Application.ScreenUpdating = False
SheetX.Columns(ClearColumns).ClearContents
SheetY.Columns(ClearColumns).ClearContents
ResultRange.Offset(SheetSu.Range("Z" & Rows.Count).End(xlUp).Row - 5).Value = ResultRange.Value
Application.ScreenUpdating = True
MsgBox "Finish"

End Sub

お礼

ありがとうございます。
説明不足で申し訳ございません。

最終的に欲しいものはresultrangeのみです。ですので、シートＸＹは最終的にクリアしても構いません。

行数を決定→選択するセル範囲の決定→シートＸＹに貼り付け→resultrangeにその結果が返る→resultrangeの下に順番に貼り付け→行数の項目が空白になるまでループ
というような仕組みです。

＞＞ResultRange.Offset(SheetSu.Cells(Rows.Count, "Z").End(xlUp).Row - 5).Value = ResultRange.Value
の間違いではなでしょうか？

なるほど、
Application.ScreenUpdating = False のコードと
SheetSuの画面で実行を行ったために、うまくいったのでしょうか。
編集をしておきます。

ありがとございました。

回答No.1

mt2008

CopyとPasteを止めましょう。
時間が掛る元です。

例えば、このコードより
Sheets("Sheet1").Range("A1:B10").Copy
Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues

こっちの方が何倍も速く処理できます。
Sheets("Sheet2").Range("A1:B10").Value = Sheets("Sheet1").Range("A1:B10").Value

お礼

ありがとうございます。
大変勉強になりました。