Results of 1 - 1 of about 1215 for （Mook）
(0.001 sec.)
- [[20150126081318]]
- #score: 9211
- @digest: ec77b0e39929ac13e5cb11826f180387
- @id: 67138
- @mdate: 2015-01-26T06:12:27Z
- @size: 17459
- @type: text/plain
- #keywords: bfjlntvwx (44989), チ" (30835), instr (12033), flag (11503), calculation (11072), elseif (10545), 実測 (8365), コス (7219), xlcalculationautomatic (6985), xlcalculationmanual (6914), イッ (6901), done (6084), スイ (5923), cells (5812), delete (5042), 抑止 (4966), enableevents (4885), like (4826), application (4203), 計測 (4195), screenupdating (3774), union (3649), 列= (3489), 稲葉 (3216), k1 (2905), 手当 (2850), 2015 (2626), ッチ (2519), 月) (2380), 効果 (2264), 速度 (2261), range (2022)
- 『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行程度の処理に1〜2分というのはかかりすぎですねぇ。 エヴェントの発生を抑止しておられますが、もし、シートに計算式が膨大に入っていると、再計算されますから 計算も処理中、抑止されれば効果があるかも。（Application.Calculation の手当て） また、2003時代ほどではないですが、行削除による画面の再描画を抑止も、気持ち程度効果的?（Application.ScreenUpdating の手当て） コードはよく読んでいませんが、InStrに時間がかかっているのかもしれません。 ちょっと、考えてみます。 （β） 2015/01/26(月) 09:10 ---- ScreenUpdatingプロパティはFalseにしておくとして、ロジックで省略できそうなのは、以下くらいですかねぇ。 遅いのは、セルに入っている文字が長いとか、連結とかして複雑だとか…。 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 ---- "C"と"R"は先頭だという点を見落としました。序盤だけの変更案の修正。 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 で、性能はわりあい高いPCです。 ご指摘通りの結果で、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 ---- みなさん。ありがとうございます。 処理速度が向上しました。 Like等今まで使ったことなかったコードが知れて勉強になりました。 （ななママ） 2015/01/26(月) 15:12... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201501/20150126081318.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97054 documents and 608267 words.
訪問者：