全シートのフッターを一括編集する

Excelで文書なんか作らすなよ...

それも数十ページすべてのフッターに社名だのページ番号入れろと...

さらにページ番号は単純連番ではなく1, 2, 3-1, 3-2, ...と微妙に枝番があると来た...

そんな面倒はマクロでやっつけてしまえ

準備

テーブルを用意

整理表という名前のテーブルを用意する

マクロ実行	シート名	フッター左	フッター中	フッター右

表示シートのリストを取得する

Getシート名リストを実行するとテーブルにシート名が列挙されます。

この時、非常時になっているシートは無視するようにしてますが、
非常時シートもリストアップしたい方はIf wb.Sheets(i).Visible = True Thenをコメントアウトして下さい。

マクロ実行列に何か入れる

1でも〇でもなんでもいいので入れるとそのシートがフッター編集対象になります。

フッターに入れたい文字列をテーブルに入れる

賢いお馬鹿機能が発動して1-1とかそのまま入れると1月1日とか余計なお世話を焼いて下さるので書式を文字列にして黙らせておいた方がいいです。

フッター一括編集を実行

以上です。

コード

Option Explicit
Const myテーブル名 = "整理表"
Enum c
  マクロ実行 = 1
  取得したシート名
  フッター左
  フッター中
  フッター右
End Enum
Type 対象
  取得したシート As Worksheet
  フッター左 As String
  フッター中 As String
  フッター右 As String
End Type
Dim Target As 対象

Sub Getシート名リスト()
  Dim wb As Workbook
  Set wb = ActiveWorkbook
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim i, Row最終
  
  Application.ScreenUpdating = False
  With ws.ListObjects(myテーブル名)
    '初期化
    .DataBodyRange.Delete
    
    'シート名をテーブルにリストアップ
    For i = 1 To wb.Sheets.Count
      If wb.Sheets(i).Visible = True Then
        .ListRows.Add
        Row最終 = .ListRows.Count
        .Range(Row最終, c.取得したシート名).Value = wb.Sheets(i).Name
      End If
    Next
  End With
  Application.ScreenUpdating = True

End Sub

Sub フッター一括編集()
  Dim wb As Workbook
  Set wb = ActiveWorkbook
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim i, Row最終
  
  Application.ScreenUpdating = False
  With ws.ListObjects(myテーブル名)
    For i = 1 To .ListRows.Count
      If .DataBodyRange(i, c.マクロ実行) <> "" Then
        Set Target.取得したシート = wb.Sheets("" & .DataBodyRange(i, c.取得したシート名) & "")
        Target.フッター左 = .DataBodyRange(i, c.フッター左)
        Target.フッター中 = .DataBodyRange(i, c.フッター中)
        Target.フッター右 = .DataBodyRange(i, c.フッター右)
        
        With Target
          If フッター編集(.取得したシート, .フッター左, .フッター中, .フッター右) = False Then
            MsgBox .取得したシート.Name & "の途中で失敗しました。"
            End
          End If
        End With
        
      End If
    Next
  End With
    
  Application.ScreenUpdating = True
  MsgBox "フッターを設定しました。"
    
End Sub

Private Function フッター編集(ws As Worksheet, フッタ左, フッタ中, フッタ右) As Boolean
  On Error GoTo Err
  With ws.PageSetup
    .LeftFooter = フッタ左
    .CenterFooter = フッタ中
    .RightFooter = フッタ右
  End With
  フッター編集 = True
  Exit Function
Err:
  フッター編集 = False
End Function

小言

フッター一括編集内のここ

Set Target.取得したシート = wb.Sheets("" & .DataBodyRange(i, c.取得したシート名) & "")

Sheets(シート名)のところ、""で挟まないとエラーになる