マクロの処理速度向上

質問

教えてください。マクロ初心者です。以下のようなマクロを組みました。
Sub 処方箋一覧()
Dim vbOK As Integer
Set WS1 = Worksheets("sheet1")
Set WS7 = Worksheets("sheet7")
WS7.Select
Range("b2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, -1).Select
ActiveCell.Offset(0, 1) = WS1.Range("B3")
ActiveCell.Offset(0, 2) = WS1.Range("h3")
ActiveCell.Offset(0, 3) = WS1.Range("q3")
ActiveCell.Offset(0, 4) = WS1.Range("v3")
ActiveCell.Offset(0, 5) = WS1.Range("y3")
　　　　　　　　～中略～
ActiveCell.Offset(0, 167) = WS1.Range("w75")
ActiveCell.Offset(0, 168) = WS1.Range("x75")
vbOK = MsgBox("入力完了!!", vbOKOnly, "処理確認")
If vbOK = 1 Then
Worksheets("sheet1").Activate
End If
End Sub
合計で167のセルを違うシートに転記するマクロです。
動作するのですが、速度が非常に遅くて困っています。
処理速度を向上させるようなマクロの組み方を調べているのですが、わからず困っています。どなたか、教えていただけると助かります。
よろしくお願いいたします。

回答No.3

end-u · ベストアンサー

追加で１点。
転記元が不規則な場合、転記元を一旦連続範囲に整理する方法もあります。
例えば"dummy"という作業用シートを追加して、
A1セルに =Sheet1!B3
B1セルに =Sheet1!H3
C1セルに =Sheet1!Q3
：以下略
と、事前に数式を設定しておけば、あとは

Sub test2()
　　With Sheets("sheet7")
　　　　.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 167).Value _
　　　　　　= Sheets("dummy").Range("A1:FK1").Value
　　End With
End Sub

お礼

回答ありがとうございました。
ダミーシートに一旦整理するという発想、勉強になりました。
驚くほど早くなり、大変助かりました。
ありがとうございました。

回答No.4

Wendy02

こんばんは。

>WS7.Select
>Range("b2").Select
>Selection.End(xlDown).Select

この配置が良く分かりません。たぶん、End(xlUp) で良いのではないかと思いましたが、おかしければ、換えてください。そのまま、xlDown したら、場合によっては、最下行まで行ってしまいます。

'-------------------------------------------

Sub PrescriptionListing1()
　　Dim WS1 As Worksheet
　　Dim WS7 As Worksheet
　　Dim sList
　　Dim arList
　　Dim i As Long, j As Long
　　Dim v As Variant
　　'-------------------------------------------
　　'ユーザー設定
　　sList = "b3,h3,q3,v3,y3,w75,x75" '(Delimiter:カンマ区切り)

　　Set WS1 = Worksheets("Sheet1")
　　Set WS7 = Worksheets("Sheet7")
　　'-------------------------------------------
　　arList = Split(sList, ",")
　　With WS7
　　　　j = .Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　　.Select
　　　　Application.ScreenUpdating = False
　　　　For Each v In arList
　　　　　　i = i + 1
　　　　　　.Cells(j, i).Value = WS1.Range(v).Value
　　　　Next v　　　　
　　　　Application.ScreenUpdating = True
　　End With
　　MsgBox "入力完了!!", , "処理確認"
　　WS1.Select

　　Set WS1 = Nothing
　　Set WS7 = Nothing
End Sub

お礼

回答ありがとうございました。
セルを整理するという考え方、参考にさせていただきました。ご指摘のとおり、End(xlUp)でも動きました。
ありがとうございました。

回答No.2

end-u

基本として、画面描画・関数再計算・イベント抑止などの、
Application.ScreenUpdating
Application.Calculation
Application.EnableEvents
といったプロパティを制御する事で速度向上が図れる場合がありますから、調べておいてください。

今回のケースでは、書き出し時に、セル１つずつ処理をしたのでは時間がかかりますから、まとめて書き出したほうが良いです。
配列を使います。

Sub test()
　　Dim ary()
　　Dim i As Long
　　Dim n As Long
　　Dim v

　　With Sheets("sheet1")
　　　　'転記元アドレスをスペース区切りで列挙
　　　　v = Split("B3 H3 Q3 V3 Y3 W75 X75")
　　　　n = UBound(v)
　　　　ReDim ary(n)
　　　　For i = 0 To n
　　　　　　ary(i) = .Range(v(i)).Value
　　　　Next
　　End With
　　'配列aryからまとめて書き出し。配列サイズが0からnなので n + 1 で書き出し先を確保
　　Sheets("sheet7").Range("B2").End(xlDown).Offset(1).Resize(, n + 1).Value = ary
End Sub

転記元の範囲に規則性があれば、アドレスを列挙せずLoop処理で可能です。

お礼

回答ありがとうございました。イベント等の動作処理にも影響するんですね。難しい配列の考え方がまだ勉強不足でわからなかったんですが、丁寧に説明していただいたので、なんとか理解できてる（？）と思います。ありがとうございました！

回答No.1

rivoisu

転送元が不規則なのでなかなか難しいですね。
確かRange(”B1")　より　cells(1,2) のほうが早いはずです（わずかですが）
このsubが何度も呼ばれるのであれば転送元のセルアドレスをいったんpublicの配列に記憶しておくのはどうでしょう。

どこかのシートにアドレス一覧を作ります。
B3は3　2
Q3は3　17
という風に168個分用意します。
最初にこれを配列に記憶します
dim adrs(168,2) as integer
for i=1 to 168
　　adrs(i,1)=cells(i,1)
　　adrs(i,2)=cells(i,2)
next

Range("b2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, -1).Select
ActiveCell.Offset(0, 1) = WS1.Range("B3")
以下　処理確認の前までを
ｗｓ7.activate
j=Range("b2").End(xlDown)..row+1
for i=1 to 168
　　cells(j,i)=ws1.cells(adrs(j,1),adrs(j,2))
next
とします。早いかどうかはやってみないと分かりませんがコードはだいぶ短くなるでしょ。
たぶん今より早いと思います。
テストしてませんのであしからず（考え方を分かってください）