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

質問

シート２のボタンをクリックすると
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

回答No.8

end-u · ベストアンサー

>..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() は速度的には大差ないと思います。

お礼

速くなりました。

本スレッドの質問
　・R列にC,D,E列の値を連結した値を転記
　・Ｓ列にＡ列の日付を編集してＳ列に転記
にて20,000行の状態で
私の記述では最初は約２５秒でした。
Sub test2
のおかげで1秒以内になりました。

・R列にC,D,E列の値を連結した値を転記
→Ａ列にＤ，Ｅ，Ｆ列の値を連結した値を転記　に流用したい

＞20,000行程度だったら
＞Sub test1改造( ) と Sub test10( ) は速度的には大差ないと思います。
↓↓
最初は私の記述で約２分。
別スレッドで教えていただいた
VLOOKUPの高速化（別方法）で６秒になり、
（別方法の部分自体は０．１秒）
Sub test1改造( )→ Sub test10( ) に変更で
３秒まで短縮されました。
（Sub test10自体は０．１秒くらい）

またコメントの方も教えていただきまして感謝いたします。

本スレッドの質問も高速化され、別ファイルへの流用まで高速化できました。

どうもありがとうございました。

補足

ありがとうございます。
Sub test10( )
は本スレッドの質問とは別の
　（１）Ａ列にD,E,Fの値を連結して転記
に流用する為に、教えていただいた記述を私が変更した→Sub test1改造　
の配列型版？でいいのですよね。
↓↓
別ファイルで　Sub test1改造　と入れ替えて問題なく動きました。

Sub test20( )　は本スレッドの質問の
　（２）Ｒ列にC,D,E列の値を連結して転記
　（３）S列にA列の日付を編集して転記
　（４）プロシージャーを分けたい
に対して（２）（３）を同時に処理を行う記述の　Sub test2( )を　
（３）のみにした物　　（別途　列削除と項目名転記部分は除く）　ですよね。

ちなみに　Sub test2( )　を（２）と（３）に分ける場合は
　・Sub test10( )を記述変更
　・Sub test20( )はそのまま
でいいと思い、

Sub test10( )を
Ａ列にD,E,Fの値を連結して転記
↓↓
Ｒ列にC,D,Eの値を連結して転記
に修正して

　Sub test10改造( )

　　'2010年11月23日
　　'R列にC,D,E列を連結させた値を転記
　　'配列型
　　'最高速型

　　 Dim mx As Long
　　Dim i As Long
　　Dim v
　　Dim w() As String '書き出し用
　　With Sheets("シート１")

　　 '●C最終行:E2の値を配列に取る
　　v = .Range("E2", .Cells(.Rows.Count, 3).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("R2").Resize(mx)

　　 .ClearContents
　　.NumberFormat = "@"
　　.Value = w
　　End With
　　End With
　　Erase w
　　End Sub
↓↓
Sub test10改造( )
Sub test20( )

と並べて動作させて
↓↓
Sub test2（ ）

と同じ結果でした。（記述の変更はこれでいいのですよね。）

本スレッドの質問のファイルは、もうプロシージャーを分ける必要が無くなりましたので
全て連結させたいただきました
Sub test2( )　を使用し

プロシージャーを分けたかった理由である別ファイルの方は今回教えていただいた
Sub test10( )
で行います。
ありがとうございました。

回答No.7

end-u

>計算式を貼り付けて、出た値を値貼付した方が
>早いのかな？ですが
サンプルとしてはこんな感じです。
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プロパティを制御。定番です。
元のコードにこの制御を加えるだけでも改善すると思われます。

お礼

Sub test1()

かなり早くなりました。

Sub test2()

1秒以内になりました。

どうもありがとうございます。

補足

大変ありがとうございました。

スレッドの質問にて
「２つのプロシージャーは分けておきたい」
と書いたのは別なものに流用したかったからです。

Sub　test2
の中には
Sub　test1
が組み込まれています。
今回は一番高速なSub test2を使用させていただきます。

今回のやりたかった事は
・R列にC,D,E列を結合した値を転記
・S列に日付を転記
でした。

で今回の質問とは別なファイルは、
A列にD,E,F列を結合した値を転記だけで
日付の転記は無いです。
教えていただいたSub test1を改造して
これで動きましたが記述があっているか不安です。
↓↓↓↓
Sub test1改造()
'2010年11月22日
'A列にD,E,F列の結合した値を転記
'計算式をA2に入れてコピー。出た値を値貼付
With Sheets("シートＺ")
'式を入れる場所はセルA2。
'最終データがある行の確認を行うのは4=D列。Rows.Countは4。
'式を入れるのはA列なのでD列より左3つ。よってOffsetは-3。
With .Range("A2", .Cells(.Rows.Count, 4).End(xlUp).Offset(, -3))
.NumberFormat = "general"
.Formula = "=D2&E2&F2"
.NumberFormat = "@"
.Value = .Value
End With
End With
End Sub

これよりもSub　test2の方が高速なので
Sub test2から日付転記部分を除去しSub test1の部分だけを　
改造しようと挑戦しましたが私の技量では、うまくできませんでした。
Ｓub　test2の改造は私では出来ませんでした。
取り合えず高速化は出来ましたので、どうもありがとうございました。

回答No.6

merlionXX

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

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

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

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

お礼

わざわざすいません。
Ｓub　検索キーのほうですが
セルＲ２
に式を入れて、オートフィルだと
秒速です。

計算式を貼り付けて、出た値を値貼付した方が
早いのかな？ですが

その記述を書けません。(ToT)/~~~

これは
シート２～６までデータが有って
その内容を全てシート１に貼り付けて
この２個のプロシージャーを走らせてシート１の値を編集しています。
ファイルサイズは１５Ｍもあります。

とりあえず、シート２～６までは不要なので
削除してシート１だけにしたら
４０秒に短縮されました。

回答No.5

merlionXX

失礼、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

お礼

ありがとうございます。
双方を変更しましたが
若干早くなりました。

回答No.4

merlionXX

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

お礼

ありがとうございます。

数値を文字列としての問題があって
値が9.01+Ｅとかなる場合がありました。

先頭に（Dim myVの前）

Sheets("シート１").Select
Columns("R:R").Select
Selection.NumberFormatLocal = "@"

と入れたら直りました。
速度は少し速くなった感じです。

回答No.3

Azzz___

こんにちは。

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

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

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)などで気をつける必要があります。

いかがでしょうか？

お礼

ありがとうございます。
少し早くなりました。

回答No.2

noname#140971

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

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

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

お礼

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

私の技量では対応出来そうもないです。

どうもありがとうございました。

回答No.1

yuzamasa1101

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

お礼

入れてみましたが、あまり変化はありませんでした。

どうもありがとうございました。