Results of 1 - 1 of about 71 for ExecuteExcel4Macro 閉じた｜開いて｜開かず (0.012 sec.)
executeexcel4macro (140), 閉じた (629), 開いて (4904), 開かず (263)
- [[20160209092836]]
- #score: 14119
- @digest: 956cdbb8bc6acd2487daf44e0dc3d5d9
- @id: 69885
- @mdate: 2016-02-11T23:38:05Z
- @size: 12875
- @type: text/plain
- #keywords: crnum (63865), extractionca (51665), ト“ (49391), 式方 (41426), 式-- (39402), 果” (37909), ctabcr (29993), 照数 (27214), va (18839), 方式 (17090), sfile (15093), spath (12202), 部参 (10877), 出結 (9115), executeexcel4macro (8361), ado (6248), 速化 (4832), 外部 (4317), 力デ (3625), 高速 (3294), 行下 (2873), 効率 (2836), variant (2333), myary (2316), ans (2245), rng (1606), 2016 (1604), 実施 (1570), 出力 (1565), array (1485), 別シ (1479), cnt (1403)
- 『以下コードの処理速度を高速化したいです』（さびさび）
実行している内容は… 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201602/20160209092836.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97055 documents and 608280 words.
訪問者：