フッターを一括編集するアドイン

昨日の続き。
ブック依存ではなく汎用ツールにしたいと思いアドイン化。

アドインシートづくり

アドインシートにこんなテーブルとボタンを設置する。※下図はGetシート名リスト実行後の状態。新設の際は見出し行だけ入れておけばいい。

ボタンにはフッター一括編集を登録しておく。
テーブル名はConst myテーブル名 = "整理表"と合わせる。

使い方

Getシート名リストを呼ぶ

クイックアクセスツールバーでもよし、リボンでもよし、右クリックメニューでもよし。

取得したブック名、シート名に対してテーブル内を設定する

• [マクロ実行]列
  1でも〇でもいいので何か入れる
• 各フッター位置の値
  所望の文字列を入れる(Set書式内で表示形式は文字列にしてある)

フッター一括編集ボタンを押す

以上。

コード

Option Explicit

Const myテーブル名 = "整理表"

Enum c
  マクロ実行 = 1
  取得したブック名
  取得したシート名
  フッター左
  フッター中
  フッター右
End Enum
Type 対象
  取得したブック As Workbook
  取得したシート As Worksheet
  フッター左 As String
  フッター中 As String
  フッター右 As String
End Type
Dim Target As 対象

Type wb_
  AddIn As Workbook
  Target As Workbook
End Type
Dim wb As wb_
Type ws_
  AddIn As Worksheet
  Target As Worksheet
End Type
Dim ws As ws_

Sub Getシート名リスト()
  If SetWbWs = False Then: End
  Dim i, Row最終

  Application.ScreenUpdating = False
  With ws.AddIn.ListObjects(myテーブル名)
    '初期化
    Call Set書式(.DataBodyRange)

    'シート名をテーブルにリストアップ
    For i = 1 To wb.Target.Sheets.Count
      If wb.Target.Sheets(i).Visible = True Then
        .ListRows.Add
        Row最終 = .ListRows.Count
        .DataBodyRange(Row最終, c.取得したブック名).Value = wb.Target.Name
        .DataBodyRange(Row最終, c.取得したシート名).Value = wb.Target.Sheets(i).Name
      End If
    Next
  End With
  Call AddInシート表示(True)
  Application.ScreenUpdating = True

End Sub

Sub フッター一括編集()
  On Error GoTo Err
  If SetWbWs = False Then: End
  Static AreaDB
  Set AreaDB = ws.AddIn.ListObjects(myテーブル名).DataBodyRange
  
  Call AddInシート表示(False)
  If SetWbWs = False Then: End
  
  Dim i, Row最終

  Application.ScreenUpdating = False
  For i = 1 To AreaDB.Rows.Count
    If AreaDB(i, c.マクロ実行) <> "" Then
      Set Target.取得したブック = Workbooks("" & AreaDB(i, c.取得したブック名) & "")
      Set Target.取得したシート = Target.取得したブック.Sheets("" & AreaDB(i, c.取得したシート名) & "")
      Target.フッター左 = AreaDB(i, c.フッター左)
      Target.フッター中 = AreaDB(i, c.フッター中)
      Target.フッター右 = AreaDB(i, c.フッター右)

      With Target
        If フッター編集(.取得したシート, .フッター左, .フッター中, .フッター右) = False Then
          MsgBox .取得したシート.Name & "の途中で失敗しました。"
          End
        End If
      End With
    End If
  Next

  Application.ScreenUpdating = True
  MsgBox Target.取得したブック.Name & "にフッターを設定しました。"
  Exit Sub
Err:
  With Err
    Select Case .Number
      Case Is = 91
        MsgBox "マクロ実行列が空のため何も処理しませんでした。"
      Case Else
        MsgBox "エラーNo." & .Number & vbLf & .Description
    End Select
  End With

End Sub

Private Function SetWbWs() As Boolean
  On Error GoTo Err
  Set wb.Target = ActiveWorkbook
  Set ws.Target = ActiveSheet

  Set wb.AddIn = ThisWorkbook
  Set ws.AddIn = wb.AddIn.Sheets(1)
  SetWbWs = True
  Exit Function
Err:
  SetWbWs = False
End Function

Sub AddInシート表示(OnOff As Boolean)
  If SetWbWs = False Then: End
  With wb.AddIn
    .IsAddin = Not (OnOff)
  End With
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

Private Sub Set書式(DataBodyRange)
  With DataBodyRange
    .Delete
    .NumberFormatLocal = "@"
  End With
End Sub

小ネタ

最近、ユーザーフォームよりもまずシートという素晴らしいオブジェクトを有効活用した方がいいのではないかと気づき、今回、アドインのシートを利用してみることにした。

それにあたって非表示状態のアドインを表示する方法を調べたところ、wb.IsAddin=falseで表示状態にすることができることが分かった。

AddInシート表示(True)で表示したいが、表示する場合がfalseなので中身にNotを使った。（Notを使ったのは初めて）

Sub AddInシート表示(OnOff As Boolean)
  If SetWbWs = False Then: End
  With wb.AddIn
    .IsAddin = Not (OnOff)
  End With
End Sub

今後の展開

シート情報を一覧にするものを起点にシート名一括変更とか他にも色々できそうなのでちょっと楽しみ。何かアイデアあればネタ下さい。

参考