[[20160209092836]] 『以下コードの処理速度を高速化したいです』(さびさび) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『以下コードの処理速度を高速化したいです』(さびさび)

実行している内容は…
1.フォルダを選択

2.A選択されたフォルダ内の.xlsxファイルを順次開き

3.BColorIndex = CTABCR(シート見出し色)に限ってCALL3つを実施する

4.CCall ExtractionCa:R列とAY列を1行目から見ていき、◎を除いて文字列が有れば
           別シート“抽出結果”のA列へ1行目から転記する。
           R列とAY列で文字列が有った場合、その1行下のセル内文字列も
  別シート“抽出結果”のB列へ1行目から転記する。
  さらに、R列とAY列で文字列が有った場合、その2行下、一列右の           セル内数値も別シート“抽出結果”のC列へ1行目から転記する。

5.DCall ExtractionCo1:C列とAJ列を6行目から見ていき、文字列が有れば
           別シート“抽出結果”のB列へ1行目から転記する。
           C列とAJ列で文字列が有った場合、その1行下、15列右(R,AY列)の セル内文字列も別シート“抽出結果”のA列へ1行目から転記する。

6.ECall ExtractionCo2:AC列とBJ列を6行目から見ていき、文字列が有れば
           別シート“抽出結果”のB列へ1行目から転記する。
           AC列とBJ列で文字列が有った場合、その1行下、11列左(R,AY列)のセル内文字列も別シート“抽出結果”のA列へ1行目から転記する。

7.一つのファイルを開き、4・5・6を実行した後、そのファイルを閉じ、次を開き、 4・5・6を実行…を繰り返す。

8.選択したフォルダ内の全ファイルで実行されたら完了。

PCのスペックにもよると思いますが
フォルダをローカルに作成して、7つのファイル(1つ容量:10〜30MB)を格納した場合
約3分程度掛かります。

ファイルを開かずに処理(ExecuteExcel4Macro等)とか、何か下記コードを高速化できる余地が有れば
そのコードを教えて下さい。 

−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
Public Sub Extraction()

    Dim sPath As String, sFile As String
    Dim ws As Worksheet
    Dim rng As Range
    Const CTABCR As Long = 33

    With Application.FileDialog(msoFileDialogFolderPicker)
       If (Not .Show) Then Exit Sub
       sPath = .SelectedItems(1) & "\"
    End With

    Application.ScreenUpdating = False
    sFile = Dir(sPath & "*.xlsx")
    While (sFile <> "")
       If (rng Is Nothing) Then
          Set rng = ThisWorkbook.Worksheets("抽出結果").Range("A1:C1")
       End If
       With Workbooks.Open(sPath & sFile, ReadOnly:=True)
          For Each ws In .Worksheets
             If (ws.Tab.ColorIndex = CTABCR) Then
                Call ExtractionCa(rng, ws)
                Call ExtractionCo1(rng, ws)
                Call ExtractionCo2(rng, ws)
             End If
          Next
          .Close False
       End With
       sFile = Dir()
    Wend
    Application.ScreenUpdating = True
 End Sub

 Private Sub ExtractionCa(rng As Range, ws As Worksheet)
    Dim vA As Variant, v As Variant
    Dim i As Long
    Const CRNUM As Long = 50

    For Each v In Array("R", "AY")
       vA = ws.Cells(1, v).Resize(CRNUM + 2, 2).Value
       i = 1
       While (i <= CRNUM)
          If (vA(i, 1) = "◎") Then
             i = i + 2
          ElseIf (vA(i, 1) <> "") Then
             rng.Value = Array(vA(i, 1), vA(i + 1, 1), vA(i + 2, 2))
             Set rng = rng.Offset(1)
             i = i + 2
          End If
          i = i + 1
       Wend
    Next
 End Sub

Private Sub ExtractionCo1(rng As Range, ws As Worksheet)

    Dim vA As Variant, v As Variant
    Dim i As Long
    Const CRNUM As Long = 48

    For Each v In Array("C", "AJ")
       vA = ws.Cells(1, v).Resize(CRNUM + 1, 16).Value
       i = 6
       While (i <= CRNUM)
          If (vA(i, 1) = "◎") Then
             i = i + 2
          ElseIf (vA(i, 1) <> "") Then
             rng.Value = Array(vA(i + 1, 16), vA(i, 1), "1")
             Set rng = rng.Offset(1)
             i = i + 2
          End If
          i = i + 1
       Wend
    Next
 End Sub

 Private Sub ExtractionCo2(rng As Range, ws As Worksheet)
    Dim vA As Variant, v As Variant
    Dim i As Long
    Const CRNUM As Long = 48

    For Each v In Array("R", "AY")
       vA = ws.Cells(1, v).Resize(CRNUM + 1, 12).Value
       i = 6
       While (i <= CRNUM)
          If (vA(i, 12) = "◎") Then
             i = i + 2
          ElseIf (vA(i, 12) <> "") Then
             rng.Value = Array(vA(i + 1, 1), vA(i, 12), "1")
             Set rng = rng.Offset(1)
             i = i + 2
          End If
          i = i + 1
       Wend
    Next
 End Sub
−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 コードには目を通していませんが、過去に、大きなファイルの処理時間に関して、
 ブックを開いて処理する、開かずに処理する という方式でichinoseさん、半平太さんによる検証が行われました。

[[20151023213330]]? 『別Bookからのデータ転記について』(エイチ・アイ)

 結果としては、

 ・膨大なブックであれば ADO方式-->外部参照数式方式-- がく〜んと効率が悪くなって --> ExecuteExcel4Macro方式 --> ブックを開く方式
  こんな処理効率順でした。
 ・通常のサイズのブックであれば、 ADO方式-->外部参照数式方式-->ブックを開く方式 -- がく〜んと効率が悪くなって --> ExecuteExcel4Macro方式
  こんな結果です。

 いずれにしても、効率の悪い ExecuteExcel4Macro方式 の出番はないんだろうなぁという結果でした。
 大きなサイズのブックを相手にするなら、ADO方式 あるいは 外部参照数式方式を試してみてはいかがでしょう。

(β) 2016/02/09(火) 10:20


  ・膨大なブックであれば ADO方式-->外部参照数式方式-- がく〜んと効率が悪くなって --> ExecuteExcel4Macro方式 --> ブックを開く方式

 より正確に表現するなら

 ・膨大なブックであれば ADO方式-->外部参照数式方式-- がく〜んと効率が悪くなって --> ExecuteExcel4Macro方式 -- さらに効率が悪くなって --> ブックを開く方式

(β) 2016/02/09(火) 10:34


(???) 2016/02/09(火) 10:43


問題無さそうですが、念のため。
「データ」−「リンクの編集」を確認し、不要な定義が無いか確認するとか。
シートの方に計算式を使っているのならば、自動計算も止めるとか?

ロジック的には、既にデータを一気に配列に読み込んで高速化を図っているようなので、現状で良いと思います。
DB扱いして読み込む場合、数値関係で癖があったりするので、数分くらいなら待っても良いかと。
(???) 2016/02/09(火) 10:45


βさん、???さんへ

 ADO方式もしくは外部参照数式方式を検討して
 置き換え無理(スキル足らず)なら、現状のままにします。

(さびさび) 2016/02/09(火) 13:34


やはり、ADO方式へ置き換えを実施したいです
何方か、上記コードを置き換える事が出来る方は居ませんでしょうか?
βさん、???さん
話が変わってしまい、申し訳ありません。

色々と調べて弊方では無理そうですが
もし、ADOで高速化が図れるのであれば御願いしたく。

宜しくお願い致します。

(さびさび) 2016/02/10(水) 10:10


 見た限り、遅いのは書き出しのときに一々Rangeでアクセスしてるところかなーと。
 >rng.Value = Array(vA(i + 1, 1), vA(i, 12), "1")

 1)Valueを取ってみる
 2)自動計算を手動にする
 3)screenupdatingをFalseにする

 それでもだめなら、コードを読んで変更するのは手間なので
 今ある表と、変換したあるべき表の例を
[[20110209184943]] 『[談]シートレイアウトの投稿どうしてますか?』(momo)
 これを使って提示する

 てな具合でどうですか?
(稲葉) 2016/02/10(水) 10:20

 3)既にやってありましたね・・・

 コード読んで整頓してみました。
 テストデータが無いので、試していませんが、壊れてもよいようにバックアップとってから実行してみてください。
    Option Explicit

    Public Sub Extraction()
        Dim sPath As String, sFile As String
        Dim ws As Worksheet
        Dim ans As Variant
        Dim cnt As Long
        Const CTABCR As Long = 33
        With Application.FileDialog(msoFileDialogFolderPicker)
           If Not .Show Then Exit Sub
           sPath = .SelectedItems(1) & "\"
        End With
        Application.ScreenUpdating = False
            '★出力データをansに取り込み、最後に出力する方法に変更
            cnt = 1
            ReDim ans(1 To 3, 1 To cnt)
            sFile = Dir(sPath & "*.xlsx")
            While sFile <> ""
               With Workbooks.Open(sPath & sFile, ReadOnly:=True)
                  For Each ws In .Worksheets
                     If (ws.Tab.ColorIndex = CTABCR) Then
                        Call ExtractionCa(ans, cnt, ws, 1)
                        Call ExtractionCa(ans, cnt, ws, 2)
                        Call ExtractionCa(ans, cnt, ws, 3)
                     End If
                  Next
                  .Close False
               End With
               sFile = Dir()
            Wend

            '★出力
            With ThisWorkbook.Worksheets("抽出結果")
                .Range("A1").Resize(cnt, 3).Value = Application.Transpose(ans)
            End With
        Application.ScreenUpdating = True
     End Sub
    Private Sub ExtractionCa(ByRef ans As Variant, ByRef cnt As Long, ByVal ws As Worksheet, ByVal setting As Long)
        Dim vA    As Variant
        Dim v     As Variant
        Dim i     As Long
        Dim CRNUM As Long
        Dim rsiz  As Long    '行範囲の拡張を数値で
        Dim csiz  As Long    '列範囲の拡張を数値で
        Dim strt  As Long    '処理開始行を数値で
        Dim myAry As Variant '取り込み範囲の列を配列で
        Dim op1   As Variant '出力データの1列目の入れ物
        Dim op2   As Variant '出力データの2列目の入れ物
        Dim op3   As Variant '出力データの3列目の入れ物

        '★機関部分の設定を分岐
        Select Case setting
            Case 1
                CRNUM = 50
                myAry = Array("R", "AY")
                rsiz = 2
                csiz = 2
                strt = 1
            Case 2
                CRNUM = 48
                myAry = Array("C", "AJ")
                rsiz = 1
                csiz = 16
                strt = 6
            Case 3
                CRNUM = 48
                myAry = Array("R", "AY")
                rsiz = 1
                csiz = 12
                strt = 6
        End Select

        For Each v In myAry
            vA = ws.Cells(1, v).Resize(CRNUM + rsiz, csiz).Value
            For i = strt To CRNUM Step 3  '★i + 2 のあと必ず i + 1していたので、Forでi + 3に変更
                If (vA(i, 1) = "◎") Then
                    '何もしない
                ElseIf (vA(i, 1) <> "") Then
                    '★出力部分を分岐
                    Select Case setting
                        Case 1
                            op1 = vA(i, 1)
                            op2 = vA(i + 1, 1)
                            op3 = vA(i + 2, 2)
                        Case 2
                            op1 = vA(i + 1, 16)
                            op2 = vA(i, 1)
                            op3 = "1"
                        Case 3
                            op1 = vA(i + 1, 1)
                            op2 = vA(i, 12)
                            op3 = "1"
                    End Select
                    '★これでも処理が遅ければ、Redimをやめて、始めから領域を確保する
                    cnt = cnt + 1
                    ReDim Preserve ans(1 To 3, 1 To cnt)
                    ans(1, cnt) = op1
                    ans(2, cnt) = op2
                    ans(3, cnt) = op3
                End If
            Next i
        Next v
    End Sub

(稲葉) 2016/02/10(水) 13:15


 >>やはり、ADO方式へ置き換えを実施したいです 
 >>何方か、上記コードを置き換える事が出来る方は居ませんでしょうか? 

 ご紹介したトピで ichinoseさんが提示された ADO関連コードを利用し、
 Workbooks.Open と Open後の ワークシートの取り出しを、ADO処理に変更すればいいのですが
 条件として、Sheet名がすべてわかっていること、また、各シートの1行目がタイトル行で、そのタイトル項目がわかっていることが条件になります。

 (シート名に関しては 外部参照数式方式、ExecuteExcel4Macro方式でも同様です)

 対象のブックは、どうなっていますか?

(β) 2016/02/10(水) 21:07


 追伸)

 ADO方式で与えるシート名は、シートのオブジェクト名(CodeName) のようです。
 また、コードサンプルとして、以下も参考になると思います。

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_130_090.html

(β) 2016/02/10(水) 21:25


 あっ! 

 シートタブの色を抽出条件にしていますよね。

 現在の構えでは ADO方式も 外部参照数式 方式も 使えませんね。
 Excel4 にも、機能がないのではないかと思いますので使えない?

 該当のシートの判定をシートタブの色ではなく、何かしら、セルの値として、どこかにセットしてある構成にしないと
 無理でしょうね。

(β) 2016/02/11(木) 08:57


βさん

ADO方式は弊方の場合、使用不可のようですね。
色々と対応頂き、有難う御座います。
(さびさび) 2016/02/12(金) 08:30


稲葉さん

コード纏め直して頂き、有難う御座います。
処理時間では1秒前後の差といったところでした。

やはり、ファイルオープンの処理がネックのようですが
βさんの仰る内容ですと、ADOも不可のようですし
これ以上の時間短縮は、難しいようです。

色々と対応頂き、有難う御座います。
(さびさび) 2016/02/12(金) 08:38


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.