【ExcelVBA】納品書類平準化用マクロ（自分用）

Excelのマクロです。

各シートの
・倍率を100%にそろえる
・スクロールを左上に
・A1セルを選択
各ブックの先頭のシートをアクティブ
（先頭が改訂履歴シートの場合はその次のシートをアクティブ）

Dim self As Object       'このブック
Dim currentdir As String 'カレントディレクトリ


''メインルーチン

Sub Main()

  '開始
  If MsgBox("処理を開始します", vbOKCancel) = vbCancel Then GoTo EXIT_Main
  Application.DisplayAlerts = False '警告ダイアログを無効に

  '準備
  Set self = ThisWorkbook
  currentdir = self.path


  '対象ファイルのリストを取得
  Dim targets() As String: targets = find(currentdir)


  '全ブック
  Dim target As Variant
  Dim targetBook As Workbook
  For Each target In targets

    '##編集中ファイルは無視する
    If isOpen(CStr(target)) Then GoTo CONTINUE

    '##一時ファイルは無視する
    If Left(target, 2) = "~$" Then GoTo CONTINUE

    'ファイルオープン
    On Error GoTo CONTINUE
    Set targetBook = Workbooks.Open(target, Password:="")
    On Error GoTo 0
    '##パスワード付きファイル他オープンに失敗したファイルは無視する
    If targetBook Is Nothing Then GoTo CONTINUE
    targetBook.Activate


    '##読み取り専用は無視する
    If targetBook.ReadOnly = True Then GoTo CONTINUE

    '全シート
    Dim targetSheet As Worksheet
    For Each targetSheet In targetBook.Worksheets

      targetSheet.Activate

      ''★倍率を100%にする
      ActiveWindow.Zoom = 100


      ''★スクロールをトップに
      ActiveWindow.ScrollColumn = 1
      ActiveWindow.ScrollRow = 1

      ''★セルA1にフォーカス
      ActiveSheet.Range("A1").Select


    Next targetSheet
    '/全シート



    '全シート
    Dim targetSheet2 As Variant
    For Each targetSheet2 In targetBook.Worksheets
      If targetSheet2.Name = "改訂履歴" Then
        'continue
      Else
        '履歴の次のシートにフォーカス
        targetSheet2.Activate
        Exit For
      End If
    Next targetSheet2
    '/全シート


    '保存
    targetBook.Save

    '閉じる
    targetBook.Close


    '負荷軽減
    Application.Wait [Now()] + 100 / 86400000

CONTINUE:
  Next target
  '/全ブック

EXIT_Main:
  '終了
  Application.DisplayAlerts = True '警告ダイアログを有効に
  MsgBox "終了しました", vbOKOnly

End Sub



''
'再帰的にサブフォルダまでファイルを列挙
'@param strTargetDir:探索対象のトップのフォルダ名を指定します
'@return ファイルパスの配列
''
Public Function find(strTargetDir As String) As String()


  Dim fso As Object
  Dim folder As Object


  Set fso = CreateObject("Scripting.FileSystemObject")
  Set folder = fso.GetFolder(strTargetDir)


  'カレントフォルダ内のxlsファイル
  Dim cnt As Integer: cnt = 0
  Dim files() As String

  Dim file As Variant
  For Each file In folder.files
    If Right(file.Name, 4) = "xlsx" Then
      ReDim Preserve files(cnt)
      files(cnt) = file.path
      cnt = cnt + 1
    End If
  Next file

  'サブフォルダ内を再帰検索する
  Dim subfolder As Variant
  For Each subfolder In folder.SubFolders

    Dim subfiles() As String: subfiles = find(subfolder.path)


    '再帰的呼び出し
    If Not Not subfiles Then
      Dim subfile As Variant
      For Each subfile In subfiles
        ReDim Preserve files(cnt)
        files(cnt) = subfile
        cnt = cnt + 1
      Next subfile
    End If
  Next subfolder

  '配列を返却
  find = files

  Set fso = Nothing
End Function



''
'ファイルが編集中かどうかを判定
'@param path:ファイルパス
'@return True:編集中／False:未使用
''
Function isOpen(path As String) As Boolean
    Dim result As Boolean: result = True

    On Error GoTo ERROR_isOpen
    Open path For Append As #1
    Close #1
    result = False

ERROR_isOpen:
    isOpen = result
End Function