フォルダ内のワークブックを順次処理する。

ここでは、指定したフォルダ内にある複数のExcelワークブックを順次開いて処理を行なう例を説明します。
作成済みワークブックを一括して変更したいということはよくあります。 ここでのサンプルは、指定フォルダ内の各ワークブックを順次印刷させるものですが、ここで紹介するのは「フォルダ内の各ワークブックを順次処理する」ことです。
掲示板等でこのページを紹介すると、「紹介ページは印刷ですが、やりたいことは...」などと聞き返してくる人もいるのですが、それぞれの方の100%要望の機能をサイトで用意はできません。
今回は、1ファイル単位の処理記述がどの部分なのかをわかるようにしてありますから、1ファイルの中で何をするのかを考えてトライして下さい。
このページの後半のコードは「Office 2007以降」では動きません。   元々、FileSearchは「Excel97」では「OFF97: Microsoft Office 97 プログラムには、 FileSearch が Microsoft Windows 2000 ベースのコンピュータで失敗します。」というバグが残っていますが、 今度は、FileSearchオブジェクトそのものが「Office 2007 プログラムのファイルのマクロの検索マクロを実行すると、エラー メッセージ:ランタイム エラー 5111」ということで「Office 2007」では正式にサポートされなくなりました。 つまり、FileSearchオブジェクトがまともに動くのは、「Office2000」〜「Office2003」ということになります。 「Office 2007」ではどうするかという方法を、次のページの後半で説明しています。
まずは、Dir関数で、単一フォルダに限っての方法です。
サンプルですから「処理」は印刷とします。印刷は指定されたフォルダにある全Excelワークブックに対し、「ブック全体」を指定して印刷します。 シート上のボタンで起動させると、「フォルダの参照」のフォームが表示されます。
フォルダの参照
(画像をクリックすると、このサンプルがダウンロードできます)
ここで、Excelワークブックが収容されているフォルダを指定してOKをクリックすると、そのフォルダにある全部のExcelワークブックの全シートについて順次一括して印刷が行なわれます。
Excelワークブックが存在しないワークブックを指定したり、キャンセルすると、
このフォルダにはExcelワークブックは存在しません。
のメッセージが表示されます。
単一フォルダの場合はこの方法でも構いませんが、配下のサブフォルダまで処理させる必要がある場合には、このページ後半のFileSearchオブジェクトを使う方法をおためし下さい。 さて、今回は少し長いですが、ソースコードの説明です。

'*******************************************************************************
'   指定フォルダ内の全てのワークブックの全シートを印刷
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
Const cnsYEN = "\"

'*******************************************************************************
' 指定フォルダ内の全てのワークブックの全シートを印刷
'*******************************************************************************
Sub Button1_Click()
    Dim xlAPP As Application        ' Excel.Application
    Dim strPathName As String       ' 指定フォルダ名
    Dim strFileName As String       ' 検出したファイル名
    Dim swESC As Boolean            ' Escキー判定

    ' 「フォルダの参照」よりフォルダ名の取得(modFolderPicker1に収容)
    strPathName = FolderDialog("フォルダを指定して下さい", True)     ' @
    If strPathName = "" Then Exit Sub

    ' 指定フォルダ内のExcelワークブックのファイル名を参照する(1件目)
    strFileName = Dir(strPathName & "\*.xls", vbNormal)                 ' A
    If strFileName = "" Then
        MsgBox "このフォルダにはExcelワークブックは存在しません。"
        Exit Sub
    End If

    Set xlAPP = Application                                             ' B
    With xlAPP
        .ScreenUpdating = False             ' 画面描画停止
        .EnableEvents = False               ' イベント動作停止
        .EnableCancelKey = xlErrorHandler   ' Escキーでエラートラップする C
        .Cursor = xlWait                    ' カーソルを砂時計にする
    End With
    On Error GoTo Button1_Click_ESC

    ' 指定フォルダの全Excelワークブックについて繰り返す
    Do While strFileName <> ""                                          ' D
        ' Escキー打鍵判定
        DoEvents
        If swESC = True Then                                            ' E
            ' 中断するのかをメッセージで確認
            If MsgBox("中断キーが押されました。ここで終了しますか?", _
                vbInformation + vbYesNo) = vbYes Then
                GoTo Button1_Click_EXIT
            Else
                swESC = False
            End If
        End If

        '-----------------------------------------------------------------------
        ' 検索した1ファイル単位の処理
        Call OneWorkbookProc(xlAPP, strPathName, strFileName)

        '-----------------------------------------------------------------------
        ' 次のファイル名を参照
        strFileName = Dir                                               ' I
    Loop                                                                ' J
    GoTo Button1_Click_EXIT

'----------------
' Escキー脱出用行ラベル
Button1_Click_ESC:
    If Err.Number = 18 Then                                             ' K
        ' EscキーでのエラーRaise
        swESC = True
        Resume
    ElseIf Err.Number = 1004 Then                                       ' L
        ' 隠しシートや印刷対象なしの実行時エラーは無視
        Resume Next
    Else
        ' その他のエラーはメッセージ表示後終了
        MsgBox Err.Description
    End If

'----------------
' 処理終了
Button1_Click_EXIT:                                                     ' M
    With xlAPP
        .StatusBar = False                  ' ステータスバーを復帰
        .EnableEvents = True                ' イベント動作再開
        .EnableCancelKey = xlInterrupt      ' Escキー動作を戻す
        .Cursor = xlDefault                 ' カーソルをデフォルトにする
        .ScreenUpdating = True              ' 画面描画再開
    End With
    Set xlAPP = Nothing
End Sub

'*******************************************************************************
' 1つのワークブックの処理(このサンプルでは全シート印刷)
'*******************************************************************************
Private Sub OneWorkbookProc(xlAPP As Application, _
                            strPathName As String, _
                            strFileName As String)
    '---------------------------------------------------------------------------
    Dim objWBK As Workbook          ' ワークブックObject
    ' ステータスバーに処理ファイル名を表示
    xlAPP.StatusBar = strFileName & " 印刷中...."
    ' ワークブックを開く(このサンプルでは読み取り専用)
    Set objWBK = Workbooks.Open(Filename:=strPathName & cnsYEN & strFileName, _
                                UpdateLinks:=False, _
                                ReadOnly:=True)                         ' F
    '---------------------------------------------------------------------------
    '             ↓↓↓ 検索した1ファイル単位の処理 ↓↓↓
    ' 全シートを印刷
    objWBK.PrintOut                                                     ' G
    'objWBK.PrintPreview                    ' ※お試し用(プレビュー)
    '             ↑↑↑ 検索した1ファイル単位の処理 ↑↑↑
    '---------------------------------------------------------------------------
    ' 開いたブックをClose(必要であれば保存して下さい)
    objWBK.Close SaveChanges:=False                                     ' H
    Set objWBK = Nothing
End Sub

'----------------------------<< End of Source >>--------------------------------
(ここをクリックすると、このサンプルがダウンロードできます)
@
「フォルダの参照」のダイアログからフォルダの指定を受け取ります。ここで呼び出す「FolderDialog」はmodFolderPicker1側にありますが、これについての説明は「フォルダの参照」を参照して下さい。
A
Dir関数で1件目のExcelワークブック(*.xls)のファイル名を受け取ります。ファイル名がブランクであればこのフォルダにはExcelワークブック(*.xls)が1件もないのでエラー終了とします。
B
Excelアプリケーションを取得し、画面コントロールを行ないます。画面描画(明滅)やイベント発生を抑制し、カーソルを「砂時計」にします。
C
Escキーでの動作を通常の「キー割り込み」から、「エラートラップ」に変更します。これでEscキーが打鍵されたのをエラーハンドラで受け取れるので、エラーハンドラでは中断スイッチをセットして、以後都合が良い所で実際の中断処理を行ないます。
D
ここからJまでがが、実際のファイル単位の繰り返し処理になります。通常はExcelワークブック(*.xls)のファイル名検索が終了するとこのループも終了します。
E
Escキーでの中断スイッチの判定です。実際に処理を行なうExcelワークブックをOpenする前に判定することでOpenしたまま中断してしまうなどを避けることができます。
F
ExcelワークブックのOpen(開く)処理です。strFILENAMEにはパス名は含まれないので、パス名と「\」を前に付けてフルパスのファイル名でOpenします。このサンプルの処理は「印刷」なので、リンクの更新(UpdateLinks)は行なわず、読み取り専用(ReadOnly)で開きます。
この直前でステータスバーに処理ファイル名を表示させています。
G
「ブック全体」で印刷します。テストで実際に印刷させたくない場合は、「PrintOut」の行をコメントにし、すぐ下にある「PrintPreview」の行のコメントを外して下さい。印刷がプレビューに変更されます。
H
印刷が終わったExcelワークブックを閉じます。印刷のみなので保存はしません。
I
次のExcelワークブックのファイル名をDir関数で受け取ります。
J
Dから、ここまでがExcelワークブック単位の繰り返し処理になります。ループを抜けると処理終了の行ラベルにジャンプします。
K
Dの前で実行時エラーが起きると、ここにジャンプするように「On Error GoTo」で宣言してあるので、ここではエラー処理を行ないます。エラー番号が「18」はEscキー打鍵なので本筋のエラーではありません。中断スイッチをセットしてResumeで元の行(エラー発生行)に戻します。
L
エラー番号が「1004」は実行時エラーですが、隠しシートがあるワークブックではどうしても発生してしまいます。ここでは印刷をスキップさせてClose以降に制御を戻し、次ファイルの処理を継続させています。
M
BCExcelアプリケーションの画面コントロールを変更しているので、終了時はこの状態をデフォルトに戻して終了します。
ということで、1フォルダ内に収まっているExcelワークブックを順次開いていって「何かの処理」を行なうという場合にはこのような方法を採ります。
このサンプルでは1つのExcelワークブックについての処理を「OneWorkbookProc」プロシージャに出してあるので、ここだけ要件によって書き直すようなことでも要求は満たせるのかも知れません。
※「中断機能」を付けたことでコードが長くなり、初心者の方には難しく見えてしまうかも知れませんが、誤操作の場合に処理を早急に止められるように実装しておく必要がある機能ですから、これらも含めて内容を理解して下さい。

もう一つは、FileSearchオブジェクトを利用して、サブフォルダも処理する方法です。
FileSearchオブジェクトの利用はいわゆる「検索」機能です。次のページに骨格部分を説明しているので見て下さい。
記述する側からすると、サブフォルダを含めて検索しても、結果の処理は単純ループで扱えるという利点があります。 そのまま動かしてサブフォルダ内まで全て印刷では困るので、デフォルトはプレビューにしてあります。では、そのコードを見て下さい。
FileSearchオブジェクト自体は、以前のページで紹介したFileSystemObject(FSO)のメンバではありませんが、 このサンプルでは探索したファイルの操作自体にFileSystemObject(FSO)を使っているため、「Microsoft Scripting Runtime」の参照設定は必要です。
また、前半の方法では、ブック内の全シートを印刷させようとする記述で、ブックに対して印刷していますが、その他の条件で印刷させないシートがある場合に対応できないので、こちらのコードでは非表示シートは印刷対象に含めないようにする記述にしているので、この点にも着目してみて下さい。ここでの判断条件を変更することで「設定」という名前のシートは印刷しないなどの判断も組み入れることができます。

'*******************************************************************************
'   指定フォルダ内の全てのワークブックの全シートを印刷
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
' [参照設定]
'   ・Microsoft Scripting Runtime
' ※本サンプルはFileSearchを使用しているためExcel2007以降では動作しません
'*******************************************************************************
Option Explicit

'*******************************************************************************
' 指定フォルダ内の全てのワークブックの全シートを印刷
'*******************************************************************************
Sub Button1_Click()
    Const cnsYEN = "\"
    Dim xlAPP As Application        ' Excel.Application
    Dim objFS As FileSearch         ' FileSearch
    Dim objFSO As FileSystemObject  ' FSO
    Dim vntF As Variant             ' 発見したファイル名の配列
    Dim strPathName As String       ' 指定フォルダ名
    Dim strFileName As String       ' 検出したファイル名
    Dim swESC As Boolean            ' Escキー判定

    ' 「フォルダの参照」よりフォルダ名の取得(modFolderPicker1に収容)
    strPathName = FolderDialog("フォルダを指定して下さい", True)
    If strPathName = "" Then Exit Sub

    Set xlAPP = Application
    With xlAPP
        .ScreenUpdating = False             ' 画面描画停止
        .EnableEvents = False               ' イベント動作停止
        .EnableCancelKey = xlErrorHandler   ' Escキーでエラートラップする
        .Cursor = xlWait                    ' カーソルを砂時計にする
    End With

    ' 指定フォルダ内のExcelブックを順次処理
    Set objFS = xlAPP.FileSearch
    Set objFSO = New FileSystemObject
    With objFS
        .LookIn = strPathName               ' Search開始フォルダ        ' @
        .Filename = "*.xls"                 ' 探索ファイル式            ' A
        .SearchSubFolders = True            ' サブフォルダも探索        ' B
        ' 処理開始
        If .Execute() = 0 Then                                          ' C
            MsgBox "このフォルダにはExcelワークブックは存在しません。"
            GoTo Button1_Click_EXIT
        End If
        ' 見つかったファイル分のループ
        For Each vntF In .FoundFiles                                    ' D
            ' Escキー打鍵判定
            DoEvents
            If swESC = True Then
                ' 中断するのかをメッセージで確認
                If MsgBox("中断キーが押されました。ここで終了しますか?", _
                    vbInformation + vbYesNo) = vbYes Then
                    GoTo Button1_Click_EXIT
                Else
                    swESC = False
                End If
            End If
            xlAPP.StatusBar = vntF
            ' FSOにてファイルを取得
            With objFSO.GetFile(vntF)                                   ' E
                '---------------------------------------------------------------
                ' 検索した1ファイル単位の処理
                Call OneWorkbookProc(xlAPP, .Path, .Name)
            End With
        Next vntF
    End With
    GoTo Button1_Click_EXIT

'----------------
' Escキー脱出用行ラベル
Button1_Click_ESC:
    If Err.Number = 18 Then
        ' EscキーでのエラーRaise
        swESC = True
        Resume
    ElseIf Err.Number = 1004 Then
        ' 隠しシートや印刷対象なしの実行時エラーは無視
        Resume Next
    Else
        ' その他のエラーはメッセージ表示後終了
        MsgBox Err.Description
    End If

'----------------
' 処理終了
Button1_Click_EXIT:
    With xlAPP
        .StatusBar = False                  ' ステータスバーを復帰
        .EnableEvents = True                ' イベント動作再開
        .EnableCancelKey = xlInterrupt      ' Escキー動作を戻す
        .Cursor = xlDefault                 ' カーソルをデフォルトにする
        .ScreenUpdating = True              ' 画面描画再開
    End With
    Set objFSO = Nothing
    Set objFS = Nothing
    Set xlAPP = Nothing
End Sub

'*******************************************************************************
' 1つのワークブックの処理(このサンプルでは全シート印刷)
'*******************************************************************************
Private Sub OneWorkbookProc(xlAPP As Application, _
                            strPathName As String, _
                            strFileName As String)
    '---------------------------------------------------------------------------
    Dim objWBK As Workbook          ' ワークブックObject
    Dim objSH As Worksheet          ' 処理シート
    Dim tblSH As Variant            ' 表示シートの配列を格納
    Dim IX As Long                  ' WORK
    ' ステータスバーに処理ファイル名を表示
    xlAPP.StatusBar = strFileName & " 印刷中...."
    ' ワークブックを開く(このサンプルでは読み取り専用)
    ' 今回はstrPathNameにファイル名が含まれます
    Set objWBK = Workbooks.Open(Filename:=strPathName, _
                                UpdateLinks:=False, _
                                ReadOnly:=True)                         ' F
    '---------------------------------------------------------------------------
    '             ↓↓↓ 検索した1ファイル単位の処理 ↓↓↓
    ' 全シートを印刷(非表示シートを除外)
    ReDim tblSH(0)
    IX = 0
    For Each objSH In objWBK.Worksheets
        If objSH.Visible = xlSheetVisible Then
            ReDim Preserve tblSH(IX)
            tblSH(IX) = objSH.Name
            IX = IX + 1
        End If
    Next objSH
    'Worksheets(tblSH).PrintOut              ' ※印刷
    Worksheets(tblSH).PrintPreview          ' ※プレビュー
    '             ↑↑↑ 検索した1ファイル単位の処理 ↑↑↑
    '---------------------------------------------------------------------------
    ' 開いたブックをClose(必要であれば保存して下さい)
    objWBK.Close SaveChanges:=False
End Sub

'----------------------------<< End of Source >>--------------------------------
(ここをクリックすると、このサンプルがダウンロードできます)
@
LookInプロパティは、FileSearchのルートフォルダの指定です。
A
Filenameプロパティは、FileSearchの探索するファイル名の指定です。 この指定には、一般にフォルダ/ファイルを検索する場合の「ワイルドカード」が指定できるので、「?」「*」などが利用できます。 「*.xls」だと、「拡張子がxlsのファイルは全て」ということになります。
B
SearchSubFoldersプロパティは、LookInプロパティで指定したフォルダから、配下のサブフォルダを含めて探索するかどうかの指定です。 配下にサブフォルダがなければこの指定は関係ありませんが、配下にサブフォルダがある場合は、そのサブフォルダまで探索するかを指定します。
C
Executeメソッドで検索処理が開始されます。結果の件数が返るので、ゼロなら対象ファイルがないことになります。
D
処理対象のファイルが見つかった場合、それが複数ある場合の対応としてのループ処理を形成します。
E
FileSearchオブジェクトから渡されるvntSHは、内容はフルパスファイル名になっています。 処理対象がExcelワークブックであれば、このままでもブックをOpenさせて、そのWorkbookオブジェクトを確保しておけば 処理上では問題はありませんが、処理対象はFileSystemObject(FSO)を使ってFileオブジェクトに確保させておきます。
F
非表示シートを除いて、シート名の配列を作成して印刷させるようにしています。