VBAサンプル2(ワークシートフッター設定)

1.機能

指定したディレクトリ下に格納された全てのExcelファイルについて、全シートのフッターを一括設定する。(対象はサブディレクトリも含む)

vba2_01.PNG

2.実行方法

①当Excelブックを開いている状態で、開発タブ/マクロより「setAllFooter」を実行する。

②表示されるフォルダ選択ダイアログで対象フォルダを指定する。

vba2_02.PNG

③表示される「ワークシートフッター設定」ダイアログにて各入力を行い、「実行」をクリックすると、処理が開始される。※処理が終わらない場合、Escキーで中断・終了させる

vba2_03.PNG

3.ダウンロードファイル

 Excelファイル(vbasample_02.xlsm)

※ファイルダウンロードができない環境の場合、下記手順でExcelブックを作成してください。

①「4.ソースコード」の内容をコピー&ペーストし、PCローカルディスクへ任意ファイル名で保存。
 (標準モジュール、フォームモジュールそれぞれを保存)

②Excelを起動し、空の内容で一旦、xlsm形式で保存

③VBEを開き、保存したファイルをインポート

④VBE上で参照設定を実施

4.ソースコード

■標準モジュール

Attribute VB_Name = "Module1"
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''
'シートフッター設定機能           2017/1/1 M.Ikeda
'
'   参照設定:MicrosoftScriptingRuntime
'
'''''''''''''''''''''''''''''''''''''''''''''''''''
Const CYCLE_DOEVENTS As Long = 1000                     '定数定義:DoEvents実行周期

Dim fileInfoList As Collection                          '標準モジュール内グローバル変数:ファイルリスト情報
Dim errList As Collection                               '標準モジュール内グローバル変数:エラーリスト情報
Dim cntDoEvents As Long                                 '標準モジュール内グローバル変数:DoEvents実行用カウンタ

Public footerLeft As String                             'public変数:フッター設定値用
Public footerCenter As String                           'public変数:フッター設定値用
Public footerRight As String                            'public変数:フッター設定値用
Public footerValidFlg As Boolean                        'public変数:フッター設定値用

'#######################################
'メインメソッド
'#######################################
Public Sub setAllFooter()
    Dim fso As FileSystemObject
    Dim fd As Folder

    Set fso = New FileSystemObject
    Set fileInfoList = New Collection
    Set errList = New Collection

    '************************************
    'フォルダ選択ダイアログ表示
    '************************************
    With Excel.Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "c:\"
        .AllowMultiSelect = False
        .Title = "フォルダの選択"
        If .Show = -1 Then
            Set fd = fso.GetFolder(.SelectedItems(1))
        Else
            Exit Sub
        End If
    End With

    '************************************
    'シートフッター設定ダイアログ表示
    '************************************
    footerValidFlg = False
    UserForm1.Show
    If footerValidFlg = False Then
        Exit Sub
    End If

    Excel.Application.ScreenUpdating = False                '性能対応:ワークシート自動更新抑止
    Excel.Application.Calculation = xlCalculationManual     '性能対応:ワークシートの数式自動更新抑止
    Excel.Application.DisplayAlerts = False                 '処理中断抑止:警告ダイアログ表示抑止

    '************************************
    'ファイルリスト情報取得処理
    '************************************
    cntDoEvents = 1
    getFileInfo fd

    '************************************
    'シートフッター設定処理
    '************************************
    Dim v As Variant
    For Each v In fileInfoList
        setFooter CStr(v), footerLeft, footerCenter, footerRight
    Next

    Excel.Application.ScreenUpdating = True
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.DisplayAlerts = True
    Excel.Application.StatusBar = ""

    MsgBox "処理完了"
End Sub

'#######################################
'再帰呼出し用のファイル情報取得処理
'#######################################
Private Sub getFileInfo(baseFolder As Folder)
    Dim fd As Folder
    Dim fl As file

    On Error GoTo Err
    For Each fl In baseFolder.Files
        If InStr(fl.Type, "Excel") > 0 Then
            fileInfoList.Add fl.Path
            'ステータスバー更新
            Excel.Application.StatusBar = fl.Path & "\" & fl.Name

            '一定周期でOSへ制御を渡す(ESCキー受付対応)
            If cntDoEvents > CYCLE_DOEVENTS Then
                DoEvents
                cntDoEvents = 1
            Else
                cntDoEvents = cntDoEvents + 1
            End If
        End If
    Next

    For Each fd In baseFolder.SubFolders
        getFileInfo fd
    Next
    Exit Sub

Err:
    Debug.Print "file access error. folderName:" & baseFolder
    errList.Add baseFolder
End Sub

'#######################################
'ワークシートフッター設定、ブック保存
'#######################################
Private Sub setFooter(fpath As String, footerLeft As String, footerCenter As String, footerRight As String)
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks.Open(fpath)
    For Each ws In wb.Worksheets
        ws.PageSetup.LeftFooter = footerLeft
        ws.PageSetup.CenterFooter = footerCenter
        ws.PageSetup.RightFooter = footerRight
    Next
    wb.Save
    wb.Close
End Sub


■フォームモジュール

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm1 
   Caption         =   "ワークシートフッター設定"
   ClientHeight    =   2205
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   9195
   OleObjectBlob   =   "UserForm1.frx":0000
   StartUpPosition =   1  'オーナー フォームの中央
End
Attribute VB_Name = "UserForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub CommandButton1_Click()
    footerLeft = Me.TextBox1
    footerCenter = Me.TextBox2
    footerRight = Me.TextBox3
    footerValidFlg = True
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Me.TextBox1 = ""
    Me.TextBox2 = "&P/&N"
    Me.TextBox3 = "Copyright (C) 2018 XXXX. All Rights Reserved."
End Sub