マクロLOOP文を別方法で高速化

Question

シート２のボタンをクリックすると
Sub　編集が起動します。
Sub　編集にはＣａｌｌで2種類のプロシージャーを
呼び出します。
シート１には約20,000行のデータがあります。
処理に約2分かかっています。
もう少し高速にする方法は
有りますでしょうか？
プロシージャーは分けておきたいです。
シートに式は入れたくありません。
Sub　編集にはCall文でさらに別のプロシージャーを5個呼び出しますが
Ｆ８キーで確認すると、それらは秒速で処理されてました。
一番時間がかかっているのがこの部分なので
この部分を対策したいです。
よろしくお願いします。

Sub 編集()

Call 検索キー
　Call 日付02

Sheets("シート１").Select
　　Range("R1") = "キー"
　　Range("S1") = "日付"
　　Columns("B:B").Select
　　Selection.Delete Shift:=xlToLeft
　　Columns("F:F").Select
　　Selection.Delete Shift:=xlToLeft
　　Columns("H:O").Select
　　Selection.Delete Shift:=xlToLeft
　　Range("A1").Select
　　MsgBox "編集終了"
　　Sheets("シート２").Select
End Sub

Sub 検索キー()
　　　'2010年11月17日
　　　'R列にC,D,E列を連結させた値を転記
　　　　Sheets("シート１").Select
　　　　行 = 2
　　　　Do
　　　　If Cells(行, 1).Value = "" Then Exit Do
　　　　Cells(行, 18).Value = Cells(行, 3) & Cells(行, 4) & Cells(行, 5)
　　　　行 = 行 + 1
　　　　Loop
　　　End Sub

Sub 日付02()

'2010年11月17日
　　　　'A列の値、半角数字8桁を下4桁で
　　　　'2桁目に/を入れてS列に転記（セルの値もセル表示も）
　　　　'例：A列20101117　S列　11/17
　　　　'セルの値が2010/11/17でセルの表示が11/27は不可

Sheets("シート１").Select
　　　　　For 行 = 2 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　　With Cells(行, 19)
　　　　　.NumberFormat = "@"
　　　　　.Value = Format(Cells(行, 1), "!@@/@@")
　　　　　End With
　　　　　Next
　　　End Sub

end-u · Accepted Answer

>..Sub test1を改造して
>これで動きましたが記述があっているか不安です。
あってますよ。
コメントは
>'計算式をA2に入れてコピー。出た値を値貼付
貼付というより
'計算式をA2に入れてコピー。計算式を値化。
がしっくりくるかも。
.Range(..).Value = .Range(..).Value
左辺のセル範囲の.Valueプロパティに右辺のセル範囲の.Valueをセットする、
という認識でいいと思います。

ついでに書いておきますと

Sub test10()
　　Dim mx As Long
　　Dim i　As Long
　　Dim v
　　Dim w() As String　　'書き出し用

With Sheets("シート●")
　　　　'D最終行:F2の値を配列に取る
　　　　v = .Range("F2", .Cells(.Rows.Count, 4).End(xlUp)).Value
　　　　mx = UBound(v)
　　　　'必要サイズの配列を準備。
　　　　ReDim w(1 To mx, 1 To 1)
　　　　'Loop処理
　　　　For i = 1 To mx
　　　　　　w(i, 1) = v(i, 1) & v(i, 2) & v(i, 3)
　　　　Next
　　　　'書き出し
　　　　With .Range("■").Resize(mx)
　　　　　　.ClearContents
　　　　　　.NumberFormat = "@"
　　　　　　.Value = w
　　　　End With
　　End With
　　Erase w
End Sub

Sub test20()
　　Dim mx As Long
　　Dim i　As Long
　　Dim v
　　Dim w() As String　　'書き出し用

With Sheets("シート●")
　　　　'A2:A最終行の値を配列に取る
　　　　v = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Value
　　　　mx = UBound(v)
　　　　'必要サイズの配列を準備。
　　　　ReDim w(1 To mx, 1 To 1)
　　　　'Loop処理
　　　　For i = 1 To mx
　　　　　　w(i, 1) = Format$(v(i, 1), "!@@/@@")
　　　　Next
　　　　'書き出し
　　　　With .Range("■").Resize(mx)
　　　　　　.ClearContents
　　　　　　.NumberFormat = "@"
　　　　　　.Value = w
　　　　End With
　　End With
　　Erase w
End Sub

20,000行程度だったら
Sub test1改造() と Sub test10() は速度的には大差ないと思います。

end-u · Answer

>計算式を貼り付けて、出た値を値貼付した方が
>早いのかな？ですが
サンプルとしてはこんな感じです。
Sub test1()
　　With Sheets("シート１")
　　　　With .Range("R2", .Cells(.Rows.Count, 1).End(xlUp).Offset(, 17))
　　　　　　.NumberFormat = "general"
　　　　　　.Formula = "=C2&D2&E2"
　　　　　　.NumberFormat = "@"
　　　　　　.Value = .Value
　　　　End With
　　End With
End Sub

提示された情報でまとめてみると
Sub test2()
　　Dim mx As Long
　　Dim i　As Long
　　Dim v
　　Dim w() As String '書き出し用
　　
　　Dim t As Single
　　t = Timer
　　
　　'Applicationプロパティを制御。定番です。
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With

With Sheets("シート１")
　　　　'A最終行:E2の値を配列に取る
　　　　v = .Range("E2", .Cells(.Rows.Count, 1).End(xlUp)).Value
　　　　'添字最大値（セルから配列に取った場合最少値は1）
　　　　mx = UBound(v)
　　　　'必要サイズの配列を準備。
　　　　ReDim w(1 To mx, 1 To 2)
　　　　'Loop処理
　　　　For i = 1 To mx
　　　　　　w(i, 1) = v(i, 3) & v(i, 4) & v(i, 5)
　　　　　　w(i, 2) = Format$(v(i, 1), "!@@/@@")
　　　　Next
　　　　'書き出し
　　　　With .Range("R2:S2").Resize(mx)
　　　　　　'String配列を書き出す時は既データをClearContentsしたほうが速い
　　　　　　.ClearContents
　　　　　　.NumberFormat = "@"
　　　　　　.Value = w
　　　　End With
　　　　.Range("B:B,G:G,J:Q").Delete
　　End With

With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　Erase w
　　Debug.Print Timer - t
End Sub

こんな感じになるでしょうか。
>'Applicationプロパティを制御。定番です。
元のコードにこの制御を加えるだけでも改善すると思われます。

merlionXX · Answer

若干早くなった程度ですか・・・。
2000では5千ちょっとしか対応できないTransposeを使っているので20000件は試せませんが、5000件でやったところ

Sub 日付02()は 00:00:04
Sub 日付03()は 00:00:00
でした。

Sub 検索キー()   00:00:02
Sub 検索キー02() 00:00:01

です。
そんなに時間がかかるなら別の原因がありそうですね。

merlionXX · Answer

失礼、Sub 日付02()　もFor　Nextでまわしてるんでしたね。
では、これも配列に取り込みます。

Sub 日付03()
　　Dim myRng As Range
　　Dim myAr, myBr
　　Dim i As Long
　　With Sheets("シート１")
　　　　Set myRng = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp))
　　　　myAr = myRng.Value
　　　　ReDim myBr(LBound(myAr, 1) To UBound(myAr, 1))
　　　　For i = LBound(myAr, 1) To UBound(myAr, 1)
　　　　　　myBr(i) = Format(myAr(i, 1), "!@@/@@")
　　　　Next i
　　　　myRng.Offset(, 18).NumberFormat = "@"
　　　　myRng.Offset(, 18).Value = Application.Transpose(myBr)
　　End With
End Sub

merlionXX · Answer

LOOPは　Sub 検索キー　ですね。
配列に取り込むならこんな感じかな。
エクセル2003でしたよね？
2000だとエラーになります。

Sub 検索キー02()
　　　'R列にC,D,E列を連結させた値を転記
　　Dim myV
　　Dim myW
　　Dim x As Long, i As Long
　　With Sheets("シート１")
　　　　myV = .Range(.Cells(2, "A"), .Cells(2, "A").End(xlDown)).Resize(, 5).Value 'データを配列変数myVに
　　　　x = UBound(myV, 1) '行数取得
　　　　ReDim myW(1 To x)
　　　　For i = LBound(myV, 1) To UBound(myV, 1)
　　　　　　myW(i) = myV(i, 3) & myV(i, 4) & myV(i, 5) '結合データを配列変数myWに
　　　　Next i
　　　　.Cells(2, 18).Resize(x, 1).Value = Application.Transpose(myW) '転記
　　End With
End Sub

Azzz___ · Answer

こんにちは。

既に他の回答の方も書かれていますが、
配列変数を使うと高速できると思います。

イメージとしてはセルに入力されている値をチェックするのではなく、
変数に入れておいた値をチェックする感じですかね。

Do
　　　If Cells(行, 1).Value = "" Then Exit Do
　　　Cells(行, 18).Value = Cells(行, 3) & Cells(行, 4) & Cells(行, 5)
　　　行 = 行 + 1
Loop

上記のところの前に
Dim varData as variant

set varData  = Worksheet(1).Range("A1").CurrntRegion.Value

などとして変数にデータ全部を格納します。
イメージ的には上記変数varDataには表のレイアウトのまんまデータが格納されています。

それをループしてチェックするようにし、
変数に値を入れていき、最後に変数の中身をシートに吐き出す(展開する)形式にすると
処理速度は全然違うと思います。

varDataは配列となっており、ループ処理で添え字(Ubound、Lbound)などで気をつける必要があります。

いかがでしょうか？

noname#140971 · Answer

対策１、シートとのアクセス回数を減らす。
対策２、表示はまとめて最後に行う。

Step1、必要なシート情報を配列変数に取り込む。
Step2、表示する配列データを生成する。
Step3、表示する。

シート１のデータが固定性の高いものであれば、構造体変数に取り込みバイナリファイルとして吐き出しておく。この手が可能ならば１秒以内に表示が始まると思います。

yuzamasa1101 · Answer

Application.ScreenUpdating = False は入れていますか？

マクロLOOP文を別方法で高速化

>..Sub test1を改造して

この回答への補足

>計算式を貼り付けて、出た値を値貼付した方が

この回答への補足

若干早くなった程度ですか・・・。

失礼、Sub 日付02() もFor Nextでまわしてるんでしたね。

LOOPは Sub 検索キー ですね。

こんにちは。

対策１、シートとのアクセス回数を減らす。

Application.ScreenUpdating = False は入れていますか？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

失礼、Sub 日付02()　もFor　Nextでまわしてるんでしたね。

LOOPは　Sub 検索キー　ですね。