EXCELファイルのヘッダフッタ

はシート毎に６箇所もあって、後付けがめんどくさいので、あるディレクトリ以下に存在するEXCELファイルの全ファイル全シートのヘッダフッタを一括で置換するEXCELマクロを組んでみた。

以下ソースにおいて、
txtLeftHeadSize〜txtRightFootSizeが、各ヘッダ/フッタのフォントの大きさを入力するためのテキストボックス。
chkLeftHead〜chkRightFootが、各ヘッダ/フッタの置換の有無を入力するチェックボックス。
txtLeftHeadValue〜txtRightFootValueが各ヘッダ/フッタのフォントの内容を入力するためのテキストボックス。
txtFolderが該当のフォルダを指定するためのテキストボックス。

動作としては、
1）該当ファイル(拡張子が.xls)のファイルを開く
2）デフォルトのシート名を保存
3）全てのシートのヘッダ/フッタを置換
4）デフォルトのシートへ移動
5）上書き保存
6）1）へ
を行っているだけ。

    Dim lLoop        As Long
    Dim strFName     As String
    Dim strSheetName As String
    Dim wbBook       As Workbook
    Dim wsSheet      As Worksheet

    Dim fLeftHead   As Boolean  '置換の有無
    Dim fCenterHead As Boolean
    Dim fRightHead  As Boolean
    Dim fLeftFoot   As Boolean
    Dim fCenterFoot As Boolean
    Dim fRightFoot  As Boolean

    Dim sngLeftHead    As Single  '置換後のフォントサイズ
    Dim sngCenterHead  As Single
    Dim sngRightHead   As Single
    Dim sngLeftFoot    As Single
    Dim sngCenterFoot  As Single
    Dim sngRightFoot   As Single

    Dim strLeftHead    As String  '置換後の内容
    Dim strCenterHead  As String
    Dim strRightHead   As String
    Dim strLeftFoot    As String
    Dim strCenterFoot  As String
    Dim strRightFoot   As String
    
    fLeftHead = chkLeftHead.Value
    fCenterHead = chkCenterHead.Value
    fRightHead = chkRightHead.Value
    fLeftFoot = chkLeftFoot.Value
    fCenterFoot = chkCenterFoot.Value
    fRightFoot = chkRightFoot.Value
    
    sngLeftHead = IIf(IsNumeric(txtLeftHeadSize.Value), CSng(txtLeftHeadSize.Value), 11)
    sngCenterHead = IIf(IsNumeric(txtCenterHeadSize.Value), CSng(txtCenterHeadSize.Value), 11)
    sngRightHead = IIf(IsNumeric(txtRightHeadSize.Value), CSng(txtRightHeadSize.Value), 11)
    sngLeftFoot = IIf(IsNumeric(txtLeftFootSize.Value), CSng(txtLeftFootSize.Value), 11)
    sngCenterFoot = IIf(IsNumeric(txtCenterFootSize.Value), CSng(txtCenterFootSize.Value), 11)
    sngRightFoot = IIf(IsNumeric(txtRightFootSize.Value), CSng(txtRightFootSize.Value), 11)
    
    strLeftHead = txtLeftHeadValue.Value
    strCenterHead = txtCenterHeadValue.Value
    strRightHead = txtRightHeadValue.Value
    strLeftFoot = txtLeftFootValue.Value
    strCenterFoot = txtCenterFootValue.Value
    strRightFoot = txtRightFootValue.Value
    
    '指定ディレクトリイのファィル全部読み込み開始
    If Right(txtFolder.Text, 1) <> "\" Then
        txtFolder.Text = txtFolder.Text & "\"
    End If
    strFName = Dir(txtFolder.Text & "*.XLS", vbNormal)
    lLoop = 0
    
    Do While strFName <> ""
        strSheetName = ActiveSheet.Name
        Workbooks.Open txtFolder.Text & strFName
        'シートヘッダフッタ置換
        For lCnt = 1 To Workbooks(Workbooks.Count).Worksheets.Count
            Workbooks(Workbooks.Count).Worksheets(lCnt).Activate
            With ActiveSheet.PageSetup
                If fLeftHead Then
                    .LeftHeader = "&" & sngLeftHead & " " & strLeftHead
                End If
                If fCenterHead Then
                    .CenterHeader = "&" & sngCenterHead & " " & strCenterHead
                End If
                If fRightHead Then
                    .RightHeader = "&" & sngRightHead & " " & strRightHead
                End If
                If fLeftFoot Then
                    .LeftFooter = "&" & sngLeftFoot & " " & strLeftFoot
                End If
                If fCenterFoot Then
                    .CenterFooter = "&" & sngCenterFoot & " " & strCenterFoot
                End If
                If fRightFoot Then
                    .RightFooter = "&" & sngRightFoot & " " & strRightFoot
                End If
            End With
        Next
        
        lLoop = lLoop + 1
        
        For lCnt = 1 To Workbooks(Workbooks.Count).Worksheets.Count
            If Workbooks(Workbooks.Count).Worksheets(lCnt).Name = strSheetName Then
                Workbooks(Workbooks.Count).Worksheets(lCnt).Activate
                Exit For
            End If
        Next
        Workbooks(Workbooks.Count).Close SaveChanges:=True
        strFName = Dir()
    Loop
    
    If lLoop = 0 Then
        MsgBox "対象ファイルが見つかりませんでした", vbInformation
    Else
        MsgBox lLoop & "件のファイルヘッダ・フッタを置換しました", vbInformation
    End If