[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA処理の高速化』（ななママ）
不要な箇所を削除するプログラムを作成しましたが、処理に時間がかかります。
(300行程度で1分〜2分)
もっと処理速度を上げたいのですが、どうすればいいでしょうか。
Sub 抽出()
Dim k As String
Dim i As Long
Application.EnableEvents = False
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
If InStr(k, "C") = 1 Or InStr(k, "R") = 1 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "V") > 0 Or InStr(k, "T") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "L") > 0 Or InStr(k, "F") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "B") > 0 Or InStr(k, "W") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "X") > 0 Or InStr(k, "N") > 0 Or InStr(k, "J") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "S") = 1 And Cells(i, "G") = "ｽｲｯﾁ" Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "SA") = 1 Or InStr(k, "SK") = 1 Or InStr(k, "PS") = 1 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
Next i
Application.EnableEvents = True
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
常識的に考えて300行程度の処理に１〜２分というのはかかりすぎですねぇ。 エヴェントの発生を抑止しておられますが、もし、シートに計算式が膨大に入っていると、再計算されますから 計算も処理中、抑止されれば効果があるかも。（Application.Calculation の手当て） また、2003時代ほどではないですが、行削除による画面の再描画を抑止も、気持ち程度効果的？（Application.ScreenUpdating の手当て）
コードはよく読んでいませんが、InStrに時間がかかっているのかもしれません。
ちょっと、考えてみます。
（β） 2015/01/26(月) 09:10
If InStr(k, "C") = 1 Or InStr(k, "R") = 1 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "V") > 0 Or InStr(k, "T") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "L") > 0 Or InStr(k, "F") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "B") > 0 Or InStr(k, "W") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(k, "X") > 0 Or InStr(k, "N") > 0 Or InStr(k, "J") > 0 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
↓
If k like "*[BCFJLNRTVWX]*" Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
（???） 2015/01/26(月) 09:51
コードの読み取り間違いがあるかもしれませんが、とにかく InStrの利用を最小限にしてみました。 これで早くなるかどうか？お試しください。
Sub 抽出2()
Dim k As String
Dim i As Long
Dim k1 As String
Dim k2 As String
Dim flag As Boolean
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
k1 = Left(Range("F" & i).Value, 1)
k2 = Mid(Range("F" & i).Value, 1, 1)
flag = False
If k1 = "C" Or k1 = "R" Or _
k1 = "V" Or k2 = "V" Or k1 = "T" Or k2 = "T" Or _
k1 = "L" Or k2 = "L" Or k1 = "F" Or k2 = "F" Or _
k1 = "B" Or k2 = "B" Or k1 = "W" Or k2 = "W" Or _
k1 = "X" Or k2 = "X" Or k1 = "N" Or k2 = "N" Or _
k1 = "J" Or k2 = "J" Then
flag = True
ElseIf k1 = "S" And Cells(i, "G") = "ｽｲｯﾁ" Then
flag = True
ElseIf k = "SA" Or k = "SK" Or k = "PS" Then
flag = True
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
flag = True
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
If flag Then Range(Cells(i, "F"), Cells(i, "J")).Delete
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'これはなくても、自動的に元に戻りますが
End Sub
（β） 2015/01/26(月) 09:59
Like演算子案！
それとDeleteを一括に。
Sub 抽出2()
Dim k As String
Dim i As Long
Dim r As Range
Dim tbl
Application.EnableEvents = False
tbl = Range("F1", Cells(Rows.Count, "F").End(xlUp)).Value
For i = UBound(tbl) To 2 Step -1
k = Left(tbl(i, 1), 2)
If k Like "*[BFJLNTVWX]*" Or _
k Like "SA" Or _
k Like "SK" Or _
k Like "PS" Or _
k Like "[CR]*" Or _
Mid(Range("G" & i).Value, 7, 2) Like "84" Or _
(Left(k, 1) = "S" And Range("G" & i).Value = "ｽｲｯﾁ") Then
If r Is Nothing Then
Set r = Range("F" & i & ":J" & i)
Else
Set r = Union(r, Range("F" & i & ":J" & i))
End If
ElseIf Range("I" & i).Value = "DWG NAME" Then
Range("F" & i).Value = Range("J" & i).Value
End If
Next i
If Not r Is Nothing Then
r.Delete shift:=xlUp
End If
Application.EnableEvents = True
End Sub
（稲葉） 2015/01/26(月) 10:06
補足 ・マクロが遅くなる原因は、セルへのアクセスが一番多いとのことです。
・For文で毎回Cells(i , "F")のアクセスが遅くなっている要因だと思いますので tblに配列としてF列を取り込みました。
・次に毎回削除することもアクセス過多になりますので、rにRangeオブジェクトとして 削除予定の行を取り込み、最後にまとめて削除するようにしました。
（稲葉） 2015/01/26(月) 10:11
To 稲葉さん
このケースで計測はしていませんが、300件ぐらいなので、もしかしたら、削除をまとめる効果と きわめて処理コストの高い Union のデメリットが相殺されるかもしれません。
セルオブジェクトへの毎回の参照を回避する配列処理も、当然、有効ですが、たかだか 300回の参照ですから・・
なんとなく InStr処理コストの問題だと思ってるんですがねぇ・・
ところで、If の Or 結合より、コード的には、こちらのほうがわかりやすく、もしかしたら処理効率にも いい影響があるかも（？？） 実測してませんのでいいかげんな思い付きだとしかられそうですが。
Sub 抽出3()
Dim k As String
Dim i As Long
Dim k1 As String
Dim k2 As String
Dim flag As Boolean
Dim done As Boolean
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
k1 = Left(Range("F" & i).Value, 1)
k2 = Mid(Range("F" & i).Value, 1, 1)
flag = False
done = False
Select Case k1
Case "C", "R", "V", "T", "L", "F", "B", "W", "X", "N", "J"
flag = True
done = True
End Select
If Not done Then
Select Case k2
Case "C", "R", "V", "T", "L", "F", "B", "W", "X", "N", "J"
flag = True
done = True
End Select
If Not done Then
If k1 = "S" And Cells(i, "G") = "ｽｲｯﾁ" Then
flag = True
ElseIf k = "SA" Or k = "SK" Or k = "PS" Then
flag = True
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
flag = True
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
End If
End If
If flag Then Range(Cells(i, "F"), Cells(i, "J")).Delete
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'これはなくても、自動的に元に戻りますが
End Sub
（β） 2015/01/26(月) 10:28
追伸です。
もちろん、Like判定はきわめて有効ですよね。 私がアップしたコードも、その手当てすれば、k1とk2にわけなくてもすむわけですから。 ただ、"SA" や "SK" なんかは Like やるまでもなく、 kが2桁ですから 直接、同値かどうかの判定でよろしいのでは？
（β） 2015/01/26(月) 10:35
ということで（？？）稲葉さんのLikeをパクらせてもらって
Sub 抽出4()
Dim k As String
Dim i As Long
Dim k1 As String
Dim k2 As String
Dim flag As Boolean
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
k1 = Left(Range("F" & i).Value, 1)
k2 = Mid(Range("F" & i).Value, 1, 1)
flag = False
If k Like "*[BFJLNTVWX]*" Then
flag = True
ElseIf k1 = "S" And Cells(i, "G") = "ｽｲｯﾁ" Then
flag = True
ElseIf k = "SA" Or k = "SK" Or k = "PS" Then
flag = True
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
flag = True
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
If flag Then Range(Cells(i, "F"), Cells(i, "J")).Delete
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'これはなくても、自動的に元に戻りますが
End Sub
（β） 2015/01/26(月) 10:38
If Left(k, 1) Like "[CR]" Or k Like "*[BFJLNTVWX]*" Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
（???） 2015/01/26(月) 10:42
わぁ！！ 私も 抽出2 では C と R は先頭だということにしてましたが 抽出3、抽出4 では、すっかり失念してました（汗）
改訂版をです。
Sub 抽出5()
Dim k As String
Dim i As Long
Dim k1 As String
Dim k2 As String
Dim flag As Boolean
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
k1 = Left(Range("F" & i).Value, 1)
k2 = Mid(Range("F" & i).Value, 1, 1)
flag = False
If k1 = "C" Or k1 = "R" Then
flag = True
ElseIf k Like "*[BFJLNTVWX]*" Then
flag = True
ElseIf k1 = "S" And Cells(i, "G") = "ｽｲｯﾁ" Then
flag = True
ElseIf k = "SA" Or k = "SK" Or k = "PS" Then
flag = True
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
flag = True
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
If flag Then Range(Cells(i, "F"), Cells(i, "J")).Delete
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'これはなくても、自動的に元に戻りますが
End Sub
（β） 2015/01/26(月) 10:46
コードを書いていたら、ほとんど稲葉さんとβさんの改定案とほぼほぼ重なったので、 コメントだけ。
UNIONのコストが高いといっても、セル削除に比べたらそちらの方が軽いような気が しましたので、お試しで計測してみたら 300回 のセル削除・・・1.5秒 300回 のUNION ＋削除・・・0.03秒 でした。
Union を繰り返すと急速に速度が遅くなりますし、あまり多いとエラーになるので、 大量セルでは気をつけなければいけないと思いますが、300 回程度なら有効かな と思います。
（Mook） 2015/01/26(月) 10:49
To Mookさん
計測並びにご指導深謝です。
To 稲葉さん 実測もしないでいいかげんなことをいいました、申し訳ありません。 やっぱり、稲葉さんとUnion処理はえらい！
（β） 2015/01/26(月) 10:54
Sub 抽出()
Dim k As String
Dim i As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
k = Left(Range("F" & i).Value, 2)
If Left(k, 1) Like "[CR]" Or k Like "*[BFJLNTVWX]*" Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf Left(k, 1) = "S" And Cells(i, "G") = "ｽｲｯﾁ" Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf 0 < InStr("SA,SK,PS", k) Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf InStr(Cells(i, "G"), "84") = 7 Then
Range(Cells(i, "F"), Cells(i, "J")).Delete
ElseIf Cells(i, "I") = "DWG NAME" Then
Cells(i, "F").Value = Cells(i, "J").Value
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
（???） 2015/01/26(月) 10:56
Mookさんご指摘の件、こちらでも実測してみました。 環境は win8.1+xl2013 で、性能はわりあい高いＰＣです。 ご指摘通りの結果で、test1 が 0.13秒〜0.14秒。一方、test2は0.0040秒前後でしたから、ほぼゼロ。
稲葉さんとUnionによるまとめ削除に脱帽です。
Sub test1()
Dim t As Double
Dim i As Long
t = Timer
For i = 300 To 2 Step -1
Range(Cells(i, "F"), Cells(i, "J")).Delete
Next
MsgBox Timer - t
End Sub
Sub test2()
Dim t As Double
Dim i As Long
Dim r As Range
t = Timer
For i = 300 To 2 Step -1
If r Is Nothing Then
Set r = Range(Cells(i, "F"), Cells(i, "J"))
Else
Set r = Union(r, Range(Cells(i, "F"), Cells(i, "J")))
End If
Next
r.Delete
MsgBox Timer - t
End Sub
（β） 2015/01/26(月) 11:07
Like案の最初は、???さんでしたね！ 見落としていて済みません。
UNIONのコスト、ご指摘ありがとうございます。 Rangeだと文字数制限があったなーとか思いながら単純に考えてました。
もしUNIONでつなげていくなら、途中で繰り返し回数比較して、削除の構文も入れたほうが良さそうですね。 というより、「行の削除」ではなく、「範囲の削除」なので、削除より値の上書きのほうが早そう？ という分けて上書き案も。
Enum c
F1 = 1
G2 = 2
H3 = 3
I4 = 4
J5 = 5
End Enum
Sub test()
Dim tbl
Dim res
Dim n As Long
Dim m As Long
Dim F列 As String
Dim G列 As String
tbl = Range("J1", Cells(Rows.Count, "F").End(xlUp)).Value
ReDim res(1 To UBound(tbl, 1), 1 To c.J5)
m = 2
For n = 2 To UBound(tbl, 1)
F列 = Left(tbl(n, c.F1), 2)
G列 = tbl(n, c.G2)
Select Case True
Case F列 Like "*[BFJLNTVWX]*"
Case F列 Like "[CR]*"
Case F列 = "SA"
Case F列 = "SK"
Case F列 = "PS"
Case F列 Like "S*" And G列 = "ｽｲｯﾁ"
Case Mid(G列, 7, 2) = "84"
Case Else
res(m, c.F1) = IIf(tbl(n, c.I4) = "DWG NAME", tbl(n, c.J5), tbl(n, c.F1))
res(m, c.G2) = tbl(n, c.G2)
res(m, c.H3) = tbl(n, c.H3)
res(m, c.I4) = tbl(n, c.I4)
res(m, c.J5) = tbl(n, c.J5)
m = m + 1
End Select
Next n
Range("J1", Cells(Rows.Count, "F").End(xlUp)).Value = res
Range("F1:J1") = tbl
End Sub
※書き出しの順番間違えてた・・・1127修正
※I列の変数使ってなかったじゃあん・・・1132修正
（稲葉） 2015/01/26(月) 11:20
こうして詳細を確認すると、実装の際の指針になりますね。 βさんの確認に感謝。
Test1 も ScreenUpdating で描画を制御してあげると、速度が改善されました。 シートを表示していて実行と、最小化で実行だけでも数十倍違いましたので、やはり画面 処理のコストが高そうです。
それにしても、同じコードを実行して数倍の差・・・。 マシン性能の差も大きいですね（いいなぁ）。
（Mook） 2015/01/26(月) 11:22
TEST1 1.52734375 TEST2 0.03125 TEST1 0.140625 (ScreenUpdating = False)
パソコン性能の差を見せつけられました・・・
（稲葉） 2015/01/26(月) 11:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.