別ブックのデータを集計 2

はじめに

　今回は前回書いたプログラムを改善していきます。前回のプログラムはエラー処理や改善が必要な点がいくつかありますので、これらを直していきます。
　これらの手法はVBAで使われますので是非マスターしてください。
　少々内容が難しくなるので、初心者の方は参考程度にして頂ければ結構です。取り入れられるものを取り入れてみてください。

　資料は前回のものを使います。ダウンロードしていない方はこちらからどうぞ。

　今回のプログラムは標準モジュール2にあります。

Do While ～ Loop への安全対策

　前回はWhile文を嫌ってIf文に直しましたが、今回はWhile文を使い安全対策を施してみました。
　While文の危険要素は無限ループです。無限ループに陥ると、Excelを強制終了する事になるので精神衛生上良くありません。
　（これは個人的な見解かもしれませんが、、、、）

　参考ページ：DoWhileで無限ループさせないための工夫

　幸い、行をカウントするための cnt 変数がありますので、これが大きくなりすぎたら止めるようにしてみます。
　 If cnt > 1000 Then Stop
　これで、ファイルが1000より多い場合は Stop で停止します。
　Stop はブレークポイントと同じような働きをしてくれます。

'Dir関数を使ってフォルダ内のファイル一覧
Sub searchFileForDir_2()
    With Worksheets("Sheet1")

    .Range("B2") = ThisWorkbook.Path 'フォルダ名
    .Range("B3") = "集計.xlsx"       '集計ブック名

    Dim fname As String
    Dim cnt As Long
    
    fname = Dir(ThisWorkbook.Path & "\*.xls*") 'ファイルの種類を指定
    cnt = 4
    Do While fname <> ""
        If fname <> .Range("B3") And _
           fname <> ThisWorkbook.Name Then
           
            Cells(cnt, "B") = fname
            cnt = cnt + 1
        End If
        
        If cnt > 1000 Then Stop
        
        fname = Dir()
    Loop
    
    End With
End Sub

ブックを開くのに失敗した場合の対策

　ファイルが存在せずに開く事ができなかった場合、エラーが発生します。
　この時、
　Set wb = Workbooks.Open（）
　と代入する時点でエラーとなるため、後から wb が空であるのを確認しても手遅れになります。
　このようなケースでは、予めエラーが出ないように On Error Resume Next で設定にして対策します。
　最後は元通りエラーが出るように On Error GoTo 0 で戻します。
　
　　On Error Resume Next
　　（何らかの処理）
　　On Error GoTo 0

　こうすると、括弧部分の処理でエラーが発生しても無視されます。
　後から ws が空であるのを確認すれば良いので、以下のようにすれば、ブックが開けなかった場合にエラーを出さずに対処できます。

　参考ページ：ブックを開くときのエラーに対処

    On Error Resume Next
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\sample.xlsx")
    On Error GoTo 0
    
    If wb Is Nothing Then
        MsgBox "ファイルが開けませんでした。"
        Exit Sub
    End If

シートを検証する

　これから読み込むシートのデータフォーマットが正しいかどうかを検証するため、今回の売上伝票シートのA1セルには、「売上伝票」という文字列を配置して他のシートと区別するような仕様にしています。

　参考ページ：シートの有無をチェックする2つの方法

        tag = ""
        On Error Resume Next
        tag = wb.Worksheets("売上伝票").Range("A1")
        On Error GoTo 0

        If tag = "売上伝票" Then    'A1セルが「売上伝票」ならOK
            Set sh = wb.Worksheets("売上伝票")
            (色々な処理)

        End If

　この処理では、いきなり「売上伝票シート」のA1を読みに行っていますが、「売上伝票シート」がない場合には、エラーとなりますが、 On Error Resume Next でエラーは無視され、tagが空文字で If文に進みます。
　もし、「売上伝票シート」があってもA1セルが「売上伝票」と書かれていなければ If文はスルーされます。

変更したプログラムコード

　以上の2つを踏まえてプログラムコードを確認してみてください。

Sub writeData2()
    Dim i As Long, j As Long
    
    Dim 集計wb As Workbook
    Dim 集計sh As Worksheet
    
    With ThisWorkbook.Worksheets("Sheet1")
    
    Application.ScreenUpdating = False    '描画を停止　③
   
    '集計ブックを変数にセット
    On Error Resume Next
    Set 集計wb = Workbooks.Open(ThisWorkbook.Path & "\" & .Range("B3"))
    On Error GoTo 0
    If 集計wb Is Nothing Then
        MsgBox .Range("B3") & "が開けませんでした。"
        Exit Sub
    End If
    
    'データシートを開いて転記
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim tag As String
    Dim myDate As Date
    Dim b As Boolean
    For i = 4 To .Cells(Rows.Count, "B").End(xlUp).Row
        'データブックを変数にセット
        On Error Resume Next
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & .Cells(i, "B"))
        On Error GoTo 0
        If wb Is Nothing Then
            MsgBox .Cells(i, "B") & "が開けませんでした。"
            Exit Sub
        End If
        
        'データブックか検証する
        tag = ""
        On Error Resume Next
        tag = wb.Worksheets("売上伝票").Range("A1")
        On Error GoTo 0
        If tag = "売上伝票" Then    'A1セルが「売上伝票」ならOK
            Set sh = wb.Worksheets("売上伝票")
            '転記先の集計シートを取得
            b = False
            For Each 集計sh In 集計wb.Worksheets　'①
                If Year(集計sh.Range("B1")) = Year(sh.Range("B1")) And _
                    Month(集計sh.Range("B1")) = Month(sh.Range("B1")) Then
                    b = True
                    Exit For
                End If
            Next 集計sh
            If b = False Then
                MsgBox "転記先シートがありませんでした。"
                Exit For
            End If
            
            '転記
            For j = 2 To 集計sh.Cells(Rows.Count, "A").End(xlUp).Row
                If 集計sh.Cells(j, "A") = sh.Range("B1") Then '日付が同じなら
                    sh.Range("B27:H27").Copy　　'②
                    集計sh.Cells(j, "B").PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False  'クリップボードの値をクリア
                End If
            Next j
            
        End If
        
        wb.Close SaveChanges:=False 'データブックを保存せずに閉じる
        
    Next i
    
    Application.ScreenUpdating = True    '描画を再開　③
    
    End With
End Sub

コレクションのループ（For Each In ）

　コレクションとは、オブジェクトの配列の事です。具体的にはブックの中にあるシートの集団がコレクションという事になります。①
　コードで言いうと Worksheets がコレクションです。
　コレクションの要素数は、Worksheets.Count で取得できますので、以前のコードでは以下のように書いていました。

　For j = 1 To 集計wb.Worksheets.Count
　
　Next j

　これを以下のように書けます。

　Dim 集計sh As Worksheet (オブジェクト)
　For Each 集計sh In 集計wb.Worksheets (コレクション)
　
　Next 集計sh

　こうする事で、シートオブジェクトが逐次入るので、カウンタ変数( j )を省略する事ができます。
　しかし、この書き方の一番の目的は、「ブック内のシートを巡回している」という事を明示的に示す事ができる点です。
　こうする事でプログラムの見通しが良くなります。

　参考ページ：繰り返し処理

複数行のコピー

　②転記する部分が、同じような書き方の連続だったので書き変えています。

    集計sh.Cells(j, "B") = sh.Cells(27, "B")
    集計sh.Cells(j, "C") = sh.Cells(27, "C")
    集計sh.Cells(j, "D") = sh.Cells(27, "D")
    集計sh.Cells(j, "E") = sh.Cells(27, "E")
    集計sh.Cells(j, "F") = sh.Cells(27, "F")
    集計sh.Cells(j, "G") = sh.Cells(27, "G")
    集計sh.Cells(j, "H") = sh.Cells(27, "H")

　これを以下のように書き変えました。Copyコマンドで、値のみ（xlPasteValues）で貼り付けを行っています。
　最後は、クリップボードのクリアも行いました。

    sh.Range("B27:H27").Copy
    集計sh.Cells(j, "B").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False  'クリップボードの値をクリア

　参考ページ：コピーメソッド

処理中のチラつきを抑える

　転記の際に、ブックのオープン、クローズが繰り返されますので、これを抑えるために、
　Application.ScreenUpdating を使っています。③
　
　Application.ScreenUpdating = False ‘描画を停止
　（ブックOpen）
　（ブックClose）
　Application.ScreenUpdating = True ‘描画を再開
　
　こうする事で、ブックのオープン、クローズの描画を押さえてくれるので、処理中のチラつきが無くなります。

　参考ページ：備忘録

まとめ

　今回取り上げた手法は、VBAでは頻繁に出てくる慣用句のようなものなので覚えておくと良いでしょう。
　それぞれ別ページに詳細がありますので、詳しい内容はそちらを確認してください。
　今回取り上げた内容をまとめておきます。
　
　・Do While ～ Loop にはカウンタ変数を設けて無限ループを回避する
　・代入などで発生するエラーは On Error Resume Next でエラー出力を抑えて対処する
　・コレクションのループは、For Each In が使える
　・Copy、PasteSpecial Paste:=xlPasteValues、Application.CutCopyMode = False
　・Application.ScreenUpdating で描画の停止、再開