[[20190521095547]]　『複数ブックの編集・集計作業の高速化について』（みや）　ページの最後に飛ぶ

『複数ブックの編集・集計作業の高速化について』（みや）

いつも大変お世話になっております。
仕事でどうしても複数bookの編集・集計作業を行う必要が生じ、初めてVBAに触っているところです。
件名のとおりVBA高速化についてのご質問です。
目的の操作は、次のとおりです。
１まとめbook.sheet1の所定セル（A7～Q7）に値を入力
２まとめbook.sheet1のA7が、様式1book.sheet1のA7に反映しB12:Q58がA7の値に応じ変化
　まとめbook.sheet1のB7が、様式2book.sheet1のA7に反映しB12:Q58がA7の値に応じ変化
　・
　・
　まとめbook.sheet1のQ7が、様式15book.sheet1のA7に反映しB12:Q58がA7の値に応じ変化
３まとめbook.sheet2のB12:Q58に、様式1book.sheet1のB12:Q58を反映
　まとめbook.sheet3のB12:Q58に、様式2book.sheet1のB12:Q58を反映
　・
　・
　まとめbook.sheet16のB12:Q58に、様式15book.sheet1のB12:Q58を反映

以上です。
以下に書いたコードを載せます（見苦しいコードと存じております。申し訳ありません。）。
このコードでは、実行から反映まで約40秒かかります。
時間短縮できるコードについて、ご教示いただけないでしょうか。よろしくお願いいたします。

Dim wb1 As Workbook
Dim wb2 As Workbook
・
・
Dim wb15 As Workbook

Application.ScreenUpdating = False
Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\様式1.xlsm")
wb1.Worksheets(1).Range("A7") = ThisWorkbook.Worksheets(1).Range("A7")
ThisWorkbook.Worksheets(2).Range("B12:Q58").Value = wb1.Worksheets(1).Range("B12:Q58").Value
wb1.Close savechanges:=True
Application.ScreenUpdating = True

Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\様式2.xlsm")
wb2.Worksheets(1).Range("A7") = ThisWorkbook.Worksheets(1).Range("B7")
ThisWorkbook.Worksheets(3).Range("B12:Q58").Value = wb2.Worksheets(1).Range("B12:Q58").Value
wb2.Close savechanges:=True
Application.ScreenUpdating = True
・
・
Application.ScreenUpdating = False
Set wb15 = Workbooks.Open(ThisWorkbook.Path & "\大津波15.xlsm")
wb15.Worksheets(1).Range("A7") = ThisWorkbook.Worksheets(1).Range("Q7")
ThisWorkbook.Worksheets(16).Range("B12:Q58").Value = wb15.Worksheets(1).Range("B12:Q58").Value
wb15.Close savechanges:=True
Application.ScreenUpdating = True

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

質問とは関係ないですが、↓のように思うのであればインデントをつけて整理されることをお勧めします。
＞（見苦しいコードと存じております。申し訳ありません。）

さて、時間短縮できるコードについてはわかりませんが、短く書く方法なら思いつきましたので提供します。
（最後が大津波15になってますけど、様式15ですよね？）

    Sub ななしのまくろ_改()
        Dim i As Long

        '▼完成（安定動作を確認）するまで無効化推奨
        'Application.ScreenUpdating = False

        For i = 1 To 15
            With Workbooks.Open(ThisWorkbook.Path & "\様式" & i & ".xlsm")
                .Worksheets(1).Range("A7").Offset(, i - 1).Value = ThisWorkbook.Worksheets(1).Range("A7").Offset(, i - 1).Value
                ThisWorkbook.Worksheets(i + 1).Range("B12:Q58").Value = .Worksheets(1).Range("B12:Q58").Value
                .Close
            End With
        Next

        '▼完成（安定動作を確認）するまで無効化推奨
        'Application.ScreenUpdating = True

    End Sub

もとのコードのまま高速化する方法はわかりませんが、強いて言えば、Application.ScreenUpdatingを操作するのは、はじめと終わりの１回で十分なのでそこを修正すべきな点と、複雑な数式が組まれているならApplication.Calculationを一時的にxlCalculationManualにすると高速化に寄与するかもしれません。

（もこな２） 2019/05/21(火) 12:26

もこな２様

取り急ぎの返信です。
ご指摘の「大津波15」について、お見込みのとおり「様式15」です。
大変失礼しました。
教えていただいたコードの操作結果については、後ほどご報告します。
（みや） 2019/05/21(火) 12:59

 ＞＞まとめbook.sheet1のQ7が､様式15book.sheet1のA7に反映しB12: Q58がA7の値に応じ変化

↑

                        O7   【　オー　７】
でしょうか？
それとも何も規則性が無いのでしょうか。。。【　Q7　】
気が付いた点だけで。。。すみません。
私の勘違いでしたら、無視してください。
m(_ _)m
でわ

（隠居じーさん） 2019/05/21(火) 14:31

以下を参考にどこが遅いのか調べてみてはいかがですか？
http://officetanaka.net/excel/vba/tips/tips161.htm

様式１～様式１５ということは、対象ファイルが15あるということですよね。
1ファイルあたり平均2.7秒（約40秒÷15≠2.6666・・・）。
ファイルを開いて保存して閉じるだけでこのくらいはかかりそうですが、、、

（う） 2019/05/21(火) 15:37

内容はともかく、開いて閉じてRange("B12:Q58")をコピペでも
15ファイルで、一部配列使用で、特別、処理速度アップ用前処理
なしでも

 Win 　10（ 64bit）
2016　   （32bit）

６．０秒～９．５秒でした。

（隠居じーさん） 2019/05/21(火) 17:05

もなこ２様

返信が遅くなり申し訳ありません。先ほど作業開始したところです。
教えていただいたコードを実践しておりますが、まだ反映されず思考錯誤しているところです。
コードの書き方はとてもすっきりして見栄えがよくなりました。ありがとうございます。
なお、現在書いているコードは次のとおりです。ここから原因を探ってます。

Sub 角丸四角形2_Click()
Dim i As Long

        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
        Application.DisplayAlerts = False
        For i = 1 To 15
            With Workbooks.Open(ThisWorkbook.Path & "\様式" & i & ".xlsm")
                .Worksheets(1).Range("A7").Offset(, i - 1).Value = ThisWorkbook.Worksheets(1).Range("A7").Offset(, i - 1).Value
                ThisWorkbook.Worksheets(i + 1).Range("B12:Q58").Value = .Worksheets(1).Range("B12:Q58").Value
                .Close
            End With
        Next
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayAlerts = True
End Sub

（みや） 2019/05/22(水) 00:42

隠居じーさん様

返信が遅くなり大変申し訳ありません。
＞07でしょうか？
規則性はとくにないためQ7であっています。コードを細かいところまで見ていただきありがとうございます。
＞処理速度
速度について実際に試していただきありがとうございます。PCの性能も原因と考えられます。当方はwin7の2013です。

（みや） 2019/05/22(水) 00:50

う様

教えていただいたページを確認しました。
ファイルを開いて閉じるには、そもそも時間がかかるということで、勉強になりました。
ありがとうございます。
また、どんな作業にどれくらいの時間がかかるのか分析せず、質問をしてしまい失礼しましたm(__)m

（みや） 2019/05/22(水) 00:56

＞まだ反映されず思考錯誤しているところです。
どのように反映されないのか、説明いただくとアドバイスできることがあるかもしれません。

さしあたってミスがありましたので訂正です

 .Worksheets(1).Range("A7").Offset(, i - 1).Value = ThisWorkbook.Worksheets(1).Range("A7").Offset(, i - 1).Value
                         ↓
 .Worksheets(1).Range("A7").Value = ThisWorkbook.Worksheets(1).Range("A7").Offset(, i - 1).Value

高速化については、わたしも（う）さんと同じようファイルを開く部分に時間がかかっていると考えたので「高速化はわからない」としました。
ただ、例えばネットワーク越しで操作されているなど、環境に影響して遅くなっているなら、一旦全ファイルをローカルの作業フォルダに落としてから操作するなどの運用を変えることにより改善するかもしれません。

そして高速化とは逆行するかもしれませんが、Valueプロパティを見るのではなく、コピーして値を貼付でも同じ結果になりそうです。
（テストしてないのでミスっていたらごめんなさい）

    Sub ななしのまくろ_改二()
        Dim i As Long
        Dim SH As Worksheet

        With ThisWorkbook

            For i = 1 To 15
                Set SH = Workbooks.Open(ThisWorkbook.Path & "\様式" & i & ".xlsm").Worksheets(1)

                SH.Range("A7").Value = .Worksheets(1).Range("A7").Offset(, i - 1).Value

                SH.Range("B12:Q58").Copy
                .Worksheets(i + 1).Range("B12").PasteSpecial Paste:=xlPasteValues

                SH.Parent.Save
                SH.Parent.Close

            Next i

        End With

    End Sub

ちなみに、修正コードではDisplayAlertsを操作されていますが、上記のように閉じる前に（上書）保存するようにしてしまえば、確認メッセージは出ないはずですから、操作不要かもしれません。
http://officetanaka.net/excel/vba/file/file03.htm

（もこな２） 2019/05/22(水) 12:57

もなこ２様
返信が遅くなり大変申し訳ありません。
本日は、平常業務が終わらず、原因を検証できそうにありませんので、また明日、検証してご報告します。申し訳ありません。
（みや） 2019/05/22(水) 23:54

私も以前、複数のエクセルファイルを開いて、データを取り込むという処理を作成したことがあり、
時間がかかっていました。
原因は、やはり、ファイルを開いて閉じるのに時間がかかっていることでした。

値のみの取得なら、ADOで接続してもできるので、それに変更したら大幅に高速化しました。

WEB検索するとサンプルコードはいろいろ見つかります。
例えば、↓

VBA応用(ADOでExcelワークシートに接続)
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_130_090.html
（hatena） 2019/05/23(木) 09:25

 ・・と言っても、たかが15ファイルですよね。
 40秒は納得いかないなぁ・・どんだけ重いファイル群なんですかねぇ。

 同じ環境じゃないと始まらないので、みやさんの方で

 一つのファイルを単に「開いて、保存して、閉じる」で、

 何秒掛かるのか測定してもらえれば、問題の切り分けが出来るんですけども。

（半平太） 2019/05/23(木) 10:21

＞もなこ２様

○コピーして値を貼付る方法について、コードを教えていただきありがとうございます。
　実行したところ、正確に反映しました！本当にありがとうございます！
　もなこ２様のおかげで目的の操作を達成できました。重ね重ねお礼申し上げます。
　ひとまず、完成とし、時間のあるときに最適化を図っていこうと思います。

○Valueプロパティを見る方法について、コードを修正いただきありがとうございます。
　また、保存方法のアドバイスもありがとうございます。コードを次のとおり修正しました。

　Sub 角丸四角形2_Click()
　　　Dim i As Long

        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
        　For i = 1 To 15
            With Workbooks.Open(ThisWorkbook.Path & "\様式" & i & ".xlsm")
                .Worksheets(1).Range("A7").Value = ThisWorkbook.Worksheets(1).Range("A7").Offset(, i - 1).Value
                ThisWorkbook.Worksheets(i + 1).Range("B12:Q58").Value = .Worksheets(1).Range("B12:Q58").Value
                .Save
                .Close
            End With
        　Next
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
　End Sub

　このコードを実行したときの反映状況は次のとおりです。

　反映済→ThisWorkbook.sheet1のA7～Q7の値を、様式1～15book.sheet1のA7にそれぞれ反映させる
　反映済→様式1～15book.sheet1のB12:Q58の値が、シート内の数式により、変動
　未反映→様式1～15book.sheet1のB12:Q58の値を、ThisWorkbook.sheet2～16のB12:Q58にそれぞれ反映させる
　原因についてはまだわかりませんが、上記のとおり、コピーする方法で反映しましたので、一旦、作業を終えようと考えています。
　
○高速化のアドバイス（ネットワーク越しでは時間がかかること）について、ありがとうございます。
　たまたまローカルで作業していたのですが、最終的にはネットワークで職場内に共有する必要があるため、さっそくネットワークに移して実行してみました。

  アドバイスのとおり、遅くなりました（40秒→60秒）。とはいえ、1分でできるなら、手作業より大幅にスピードUPするので、共有する際は、実行にかかる時間について説明しようと思います。

＞hatena様

ADOで接続する方法について、教えていただきありがとうございます。
Webサイトを確認しました。VBAほぼ初見の私には非常にわかりやすいサイトで勉強になります。
ADOについては、操作してみて、また結果を報告します。

＞半平太様

返信いただきありがとうございます。
15ファイルは全て同じもので、１ファイルあたり、25シート、350KBです。
次のコードをローカルフォルダで実行したところ、3.12秒かかりました。

Sub 角丸四角形2_Click()

    Dim wb1 As Workbook
    Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\様式1.xlsm")
    wb1.Close savechanges:=True
End Sub

VBA初心者で恐縮ですが、高速化のいい方法がありましたら、教えていただけると幸いです。
なお、Windows7、Excel2013です。
（みや） 2019/05/23(木) 11:37

とりあえず下記のADO接続のコードで何秒かかるかためしてみては。

 Sub 角丸四角形2_Click() 
    Dim Con As Object
    Set Con = CreateObject("ADODB.Connection")
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    Con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" & _
             "Data Source=" & ThisWorkbook.Path & "\様式1.xlsm"
'    rs.Open "SELECT * FROM [Sheet1$B12:Q58];", Con
'    ThisWorkbook.Worksheets(2).Range("B12").CopyFromRecordset rs 
    rs.Close: Set rs = Nothing
    Con.Close: Set Con = Nothing
End Sub

データコピーの部分はコメントアウトしてますので、
ブックを開いてコピーもする場合の時間と比較するときは、コメントを外して比較してください。

Sheet1 の部分は実際のシート名にしてください。
（hatena） 2019/05/23(木) 14:48

hatena様

返信が遅くなり大変申し訳ありません。コードを教えていただきありがとうございます。
実際のシート名に変えて、以下のコードにて作業していますが、うまく動作せず、原因を探っています。
（実行すると「外部テーブルのフォーマットが正しくありません」とメッセージがでます。）

 Sub 角丸四角形2_Click()
    Dim Con As Object
    Set Con = CreateObject("ADODB.Connection")
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    Con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" & _
             "Data Source=" & ThisWorkbook.Path & "\大津波1.xlsm"
'    rs.Open "SELECT * FROM [Sheet1$B12:Q58];", Con
'    ThisWorkbook.Worksheets(2).Range("B12").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    Con.Close: Set Con = Nothing
 End Sub

VBAの基礎を全く知らないまま質問を重ねると、
回答いただい方に二度手間三度手間のご迷惑をおかけするので、
まずは自分で、ADOそのものと接続方法について一通り調べてみようと思います。

（みや） 2019/05/24(金) 15:40

 hatenaさんのコードのProviderをJETからACEに、Extecded PropertiesをExcel 8.0からExcel12.0に変更しました。
 あと、rs.Openがコメントアウトされているので、rs.Closeもコメントアウトしておきました。
 これで動くと思うんですけど…どうでしょうか…自信ない(^^;

 Option Explicit

 Sub 角丸四角形2_Click()
    Dim Con As Object
    Set Con = CreateObject("ADODB.Connection")
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    Con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;" & _
             "Data Source=C:\Users\M-HONDA.TOKAI\Desktop\事務用品発注用（改）.xlsm"
'    Con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" & _
'             "Data Source=C:\Users\M-HONDA.TOKAI\Desktop\事務用品発注用（改）.xlsm"
'    rs.Open "SELECT * FROM [Sheet1$B12:Q58];", Con
'    ThisWorkbook.Worksheets(2).Range("B12").CopyFromRecordset rs
'    rs.Close: Set rs = Nothing
    Con.Close: Set Con = Nothing
End Sub

（虎） 2019/05/24(金) 16:40

虎さん、フォローありがとうございますm(__)m
Excel2013 なので、そちらの方がいいですね(^^♪
（hatena） 2019/05/24(金) 17:47

コメント返信：

[ 一覧(最新更新順) ]

[[20190521095547]] 『複数ブックの編集・集計作業の高速化について』（みや） ページの最後に飛ぶ

[[20190521095547]]　『複数ブックの編集・集計作業の高速化について』（みや）　ページの最後に飛ぶ