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

Excelのマクロです。

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


```vb
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

```