Excel ドキュメントの納品時に毎回やっていることを一括自動処理する Excel VBA マクロを作った

Excel で作った設計書などを納品する際にやっていることを一括で自動処理する Excel VBA マクロを作った。

目次

• まずはコード紹介
• このマクロがやれること
• Windows・MacOS ともに動作するクロスプラットフォームを実現
• 他に課題とか
• 以上

まずはコード紹介

先にマクロを紹介する。以下のコードを「標準モジュール」として取り込んでおき、適当な Excel マクロブックから exec() サブプロシージャを呼び出してあげれば OK。

• module.bas

Option Explicit

' ================================================================================
' Format Excel Workbooks
'
' - Delete unnecessary names
' - Delete unnecessary styles
' - Zoom to 100%
' - Select A1 cell with scrolling
' - Select the first worksheet
' - Save it to './Modified/' directory (If the file exists in './Modified/' directory, it will be overwritten)
' ================================================================================
' CAUTIONS On MacOS
'
' - You can't use Japanese in VBA codes (Including comments)
' - Dir() function doesn't working in Mac Excel, So We use AppleScript instead
' - Path splitter is Slash (MacOS POSIX) or Colon (MacOS), not Backslash (Windows)
' - Backslash characters are removed when save the workbook on MacOS. So use Chr(92) instead
' ================================================================================



' The name of 'Modified' directory
Const modifiedDirectoryName As String = "Modified"

' Execute
'
' @param targetDirectoryPath Full path string of the target directory
Sub exec()
  ' Detect target directory path
  Dim targetDirectoryPath As String
  targetDirectoryPath = detectTargetDirectoryPath
  
  If targetDirectoryPath = "" Then
    Debug.Print "Abort : Target directory path is empty"
    MsgBox "ディレクトリが正しく選択されませんでした。処理を中断します"
    Exit Sub
  End If
  
  ' List file paths
  Dim filePaths() As String
  filePaths = listFilePaths(targetDirectoryPath)  ' ex. "/path/to/directory" or "/path/to/directory/"
  
  If UBound(filePaths) <= 0 Then
    Debug.Print "Abort : Excel files not exist"
    MsgBox "指定のディレクトリ配下に Excel ファイルがありませんでした。パスを確認してください"
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  ' Detect path splitter
  Dim pathSplitter As String
  pathSplitter = detectPathSplitter
  
  ' Make './Modified/' directory
  makeModifiedDirectory targetDirectoryPath, pathSplitter
  
  Dim filePath As Variant  ' For Each needs Variant
  For Each filePath In filePaths()
    formatWorkbook filePath, pathSplitter
  Next filePath
   
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
  MsgBox "完了"
End Sub

' Detect target directory path
'
' @return Target directory path
Private Function detectTargetDirectoryPath() As String
  Dim targetDirectoryPath As String
  
  If Application.OperatingSystem Like "*Mac*" Then
    Debug.Print "MacOS : Detect target directory path"
    
    ' Ignore AppleScript runtime error
    On Error Resume Next
    
    ' For allowing access to the directory
    targetDirectoryPath = MacScript("choose folder as string")
    
    If Err.Number <> 0 Then
      Debug.Print "Abort : Cancelled or runtime error : " & Err.Number & " : " & Err.Description
      Exit Function
    End If
    
    If targetDirectoryPath = "" Then
      Debug.Print "Abort : Cancelled or invalid path"
      Exit Function
    End If
    
    ' Replace to POSIX path with single quote
    targetDirectoryPath = MacScript("tell text 1 thru -2 of " & Chr(34) & targetDirectoryPath & Chr(34) & " to return quoted form of it's POSIX Path")
    ' Remove single quote
    targetDirectoryPath = Replace(targetDirectoryPath, "'", "")
    
    On Error GoTo 0
    Debug.Print targetDirectoryPath
    detectTargetDirectoryPath = targetDirectoryPath
  Else
    Debug.Print "Windows : Detect target directory path"
    
     ' Application.FileDialog(msoFileDialogFolderPicker) can't use when exec on MacOS
    targetDirectoryPath = Application.InputBox(Prompt:="対象ディレクトリへのフルパスを指定してください", Title:="対象ディレクトリへのフルパスを指定してください", Type:=2)
    
    If targetDirectoryPath = "False" Or targetDirectoryPath = "" Then
      Debug.Print "Abort : Cancelled or invalid path"
      Exit Function
    End If
    
    Debug.Print targetDirectoryPath
    detectTargetDirectoryPath = targetDirectoryPath
  End If
End Function

' List file paths
'
' @param targetDirectoryPath Full path string of the target directory
' @return Array of full path string of the files under the target directory
Private Function listFilePaths(ByVal targetDirectoryPath As String) As String()
  Dim filePaths() As String
  
  If Application.OperatingSystem Like "*Mac*" Then
    Debug.Print "MacOS : List file paths"
    
    ' Ignore AppleScript runtime error
    On Error Resume Next
    
    ' Find Excel files : do shell script "find -E '/path/to/directory' -type f -iregex '.*.[xls|xlsx|xlsm]' -maxdepth 1"
    Dim appleScript As String
    appleScript = "do shell script " & Chr(34) & "find -E '" & targetDirectoryPath & "' -type f -iregex '.*.[xls|xlsx|xlsm]' -maxdepth 1" & Chr(34)
    Debug.Print appleScript
    
    ' Execute AppleScript
    Dim result As String
    result = MacScript(appleScript)
    
    If Err.Number <> 0 Then
      Debug.Print "Abort : Failure to find files"
      MsgBox "ファイル一覧の取得に失敗しました。処理を中断します : " & vbCrLf & Err.Number & " : " & Err.Description
      Exit Function
    End If
    
    Debug.Print result
    On Error GoTo 0
    
    ' Split by CR
    filePaths = Split(result, vbCr)
    
    ' When result is empty, UBound(filePaths) is -1
    If UBound(filePaths) < 0 Then
      ReDim filePaths(0)
    End If
    
    Debug.Print UBound(filePaths) & " files"
    listFilePaths = filePaths
    Exit Function
  Else
    Debug.Print "Windows : List file paths"
    
    Dim pathSplitter As String: pathSplitter = Chr(92)  ' Backslash (Because of MacOS removing backslash characters)
    ReDim filePaths(0)
    
    ' Find files
    Dim fileName As String
    fileName = Dir(targetDirectoryPath & pathSplitter & "*.*")
    
    Do While fileName <> ""
      ' Find only Excel files
      If Right(fileName, 4) = ".xls" Or Right(fileName, 5) = ".xlsx" Or Right(fileName, 5) = ".xlsm" Then
        Dim filePath As String: filePath = targetDirectoryPath & pathSplitter & fileName
        ' Push (and extend)
        filePaths(UBound(filePaths)) = filePath
        ReDim Preserve filePaths(UBound(filePaths) + 1)
      End If
      ' Next file
      fileName = Dir()
    Loop
    
    ' Adjust length
    If UBound(filePaths) > 0 Then
      ReDim Preserve filePaths(UBound(filePaths) - 1)
    End If
    
    Debug.Print UBound(filePaths) & " files"
    listFilePaths = filePaths
    Exit Function
  End If
End Function

' Detect path splitter
'
' @return Slash (MacOS) or Backslash (Windows)
Private Function detectPathSplitter() As String
  If Application.OperatingSystem Like "*Mac*" Then
    detectPathSplitter = "/"
  Else
    detectPathSplitter = Chr(92)  ' Backslash (Because of MacOS removing backslash characters)
  End If
End Function

' Make './Modified/' directory if it doesn't exist
'
' @param targetDirectory Path Full path string of the target directory
' @param pathSplitter Character of path splitter. Slash (MacOS) or Backslash (Windows)
Private Sub makeModifiedDirectory(ByVal targetDirectoryPath As String, ByVal pathSplitter As String)
  Dim modifiedDirectoryPath As String: modifiedDirectoryPath = targetDirectoryPath & pathSplitter & modifiedDirectoryName
  
  Dim pathExists As String: pathExists = Dir(modifiedDirectoryPath, vbDirectory)
  If pathExists = "" Then
    Debug.Print "Modified directory does not exist. Make it"
    MkDir modifiedDirectoryPath
  Else
    Debug.Print "Modified directory already exists"
  End If
End Sub

' Format the workbook
'
' @param filePath Full path string of the target workbook
' @param pathSplitter Character of path splitter. Slash (MacOS) or Backslash (Windows)
Private Sub formatWorkbook(ByVal filePath As String, ByVal pathSplitter As String)
  Debug.Print "Exec format : " & filePath
  
  Dim targetWorkbook As Workbook
  
  ' Open the workbook
  On Error GoTo failureOpen
  Set targetWorkbook = Workbooks.Open(filePath)
  On Error GoTo 0
  
  ' Execute Subs
  deleteNames
  deleteStyles
  setHomePosition
  
   ' Save as './Modified/' directory
  saveWorkbook pathSplitter
  ' Close
  On Error Resume Next
  targetWorkbook.Close
  On Error GoTo 0
  Exit Sub
failureOpen:
  Debug.Print "Failure to open the workbook : " & filePath
  MsgBox "ブックを開けませんでした" & vbCrLf & filePath
  Exit Sub
End Sub

' Delete Names
'
' This Sub uses ActiveWorkbook
Private Sub deleteNames()
  On Error Resume Next
  Dim name As Variant
  For Each name In ActiveWorkbook.Names
    If InStr(name.name, "Print_Area") = 0 And InStr(name.name, "Print_Titles") = 0 And Not name.BuiltIn Then
      name.Delete
    End If
  Next
  On Error GoTo 0
End Sub

' Delete Styles
'
' This Sub uses ActiveWorkbook
Private Sub deleteStyles()
  On Error Resume Next
  Dim style As Variant
  For Each style In ActiveWorkbook.Styles
    If Not style.BuiltIn Then
      style.Delete
    End If
  Next
  On Error GoTo 0
End Sub

' Set Home Position
'
' This Sub uses ActiveWorkbook
Private Sub setHomePosition()
  Dim ws As Variant
  For Each ws In ActiveWorkbook.Worksheets
    If Worksheets(ws.name).Visible = True Then
      Worksheets(ws.name).Select
      ' Zoom to 100%
      ActiveWindow.Zoom = 100
      ' Select A1 cell with scrolling
      Application.Goto Reference:=ActiveWindow.ActiveSheet.Range("A1"), Scroll:=True
    End If
  Next
  
  ' Select the first worksheet
  For Each ws In ActiveWorkbook.Worksheets
    If Worksheets(ws.name).Visible = True Then
      Worksheets(ws.name).Select
      Exit For
    End If
  Next
End Sub

' Save Workbook
'
' This Sub uses ActiveWorkbook
'
' @param pathSplitter Character of path splitter. Slash (MacOS) or Backslash (Windows)
Private Sub saveWorkbook(ByVal pathSplitter As String)
  ' Create file name : ex. '/path/to/directory/Modified/Book.xls'
  Dim fileName As String: fileName = ActiveWorkbook.path & pathSplitter & modifiedDirectoryName & pathSplitter & ActiveWorkbook.name
  
  If Right(ActiveWorkbook.name, 5) = ".xlsx" Or Right(ActiveWorkbook.name, 5) = ".xlsm" Then
    Debug.Print "Save it to same extension (.xlsx or .xlsm)"
    On Error Resume Next
    ActiveWorkbook.SaveAs fileName:=fileName
    On Error GoTo 0
    Exit Sub
  ElseIf Right(ActiveWorkbook.name, 4) = ".xls" Then
    ' Convert '.xls' to '.xlsx' or '.xlsm'
    If ActiveWorkbook.HasVBProject Then
      Debug.Print "Save as '.xlsm'"
      On Error Resume Next
      ActiveWorkbook.SaveAs fileName:=fileName & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled
      On Error GoTo 0
      Exit Sub
    Else
      Debug.Print "Save as '.xlsx'"
      On Error Resume Next
      ActiveWorkbook.SaveAs fileName:=fileName & "x", FileFormat:=xlOpenXMLWorkbook
      On Error GoTo 0
      Exit Sub
    End If
  Else
    Debug.Print "Unspported file format : " & ActiveWorkbook.name
  End If
End Sub

コードコメントが英語なのは、Mac の VBEditor で日本語入力できないため。英文法メチャクチャで恥ずかしいから、なるべく個々の関数を簡素に作って、簡単な単語で伝わるようにした…。

以降、説明。

このマクロがやれること

このマクロがやってくれることは以下のとおり。

• 指定のディレクトリ配下にある Excel ファイル群について、次の操作を行う
  • 全てのシートで A1 セルにカーソルを合わせ、シート最上部にスクロールする
  • 全てのシートで拡大倍率を 100% にする
  • 未使用の「名前定義」を削除し、ファイルサイズを削減する
  • 未使用の「スタイル定義」を削除し、ファイルサイズを削減する
• 編集したファイルは指定のディレクトリ配下に Modified ディレクトリを作り、そこに保存するので、元ファイルは汚さない
  • .xls ファイルはマクロの有無を確かめた上で、.xlsx もしくは .xlsm 形式で保存し直し、ファイルサイズを削減する

実は個々の処理は、以前色々な記事で紹介している。

• Excel でシートを開いた時に全シート A1 セルにカーソルを合わせ、必ず1シート目を開かせるマクロ

今回はこれらの処理を一つの「標準モジュール」として統合し、ディレクトリを指定するだけで、配下のエクセルファイルを一気に修正してしまうコードにした。

Windows・MacOS ともに動作するクロスプラットフォームを実現

キモとなる整形処理は上述のとおりほとんどコードを用意してあったのだが、「複数ファイルを取得する」ために使用していた Dir() 関数が Excel for Mac では動作しないため、MacOS でも動作するよう、対象ファイルの取得方法を OS 別に用意した。

OS の判定は If Application.OperatingSystem Like "*Mac*" Then で行える。Mac の場合は AppleScript を利用してディレクトリ選択ダイアログを表示し、続いて AppleScript 経由でシェルスクリプトの find コマンドを実行し、Excel ファイルのフルパスを取得した。

Windows の場合は通常どおり Dir() で取得。Mac 側で、Excel ファイルのフルパスを配列で返していたので、戻り値の型を合わせるため、Dir() 関数の結果をフルパスに変換し、配列で返すようにした。本当は Application.FileDialog(msoFileDialogFolderPicker) とかを使って、Windows でもディレクトリ選択ダイアログを表示させたかったのだが、Mac で実行すると msoFileDialogFolderPicker の参照を解決するための参照設定が追加できず断念。Windows の場合は Application.InputBox を表示させて、対象ディレクトリへのフルパスを入力してもらうようにした。ちょっと使い勝手悪いかな。

他にも、パスの区切り文字が違ったりとなかなか難儀だったのだが、Excel ファイルを開くところまで行ければ後は問題なし。コレで Windows でも Mac でも使える Excel VBA マクロになった。

他に課題とか

とりあえずやりたいことはやれたのだが、他に課題というか、直せそうなところでいうと、以下のとおり。

• 拡張子を .XLSX など、大文字で書いている場合は上手く扱えない件。LCase() とかで小文字にして判定したりすれば良いかな。
• 「改ページプレビュー」表示などではなく、「標準ビュー」に戻したい、とかいう需要があるかも？シートごとに ActiveWindow.View = xlNormalView を実行すれば良いだけなので、よしなに。
  • 参考 : Excel VBA 改ページプレビュー、ノーマルビュー(標準)、ページレイアウト表示を切り替える -Window.Viewプロパティ-
• サブディレクトリまで再帰的に掘り下げる作りにはしていない。Mac 側は find コマンドの -maxdepth オプションを渡さないように変えるとか、Windows 側は Dir() 関数の再帰呼び出しが必要とか、面倒なのでやめた。
• 実行結果を新規 Excel ブックに書き出すとか？
• 非表示のシートは整形処理を無視している件
  • いじった方がいいのかな。
• あらゆる Excel ファイルの状態での検証ができていない
  • シートの保護があったらどうなるかな、とか、そういうところ。
• .xlb・.xlsb ファイルは無視している
  • 今どきバイナリブックにするヤツいるのか？と思って無視した。
• ファイルの作成日時・更新日時もいじりたいって？
  • Mac なら setfile と touch コマンド、Windows なら PowerShell で Set-ItemProperty を使って CreationTime と LastWriteTime を変更してください
  • (リリース後に神 Excel を書き直して日付を過去日にズラして納品とかブラックかよ…笑)

以上

操作対象のファイル一覧を特定するための処理部分が、クロスプラットフォーム対応のためになかなか苦戦した。

明らかなバグや追加要望等が挙がれば、上述の Gist を GitHub リポジトリに移して、もう少し開発してみようかなと思う所存。アドバイスなんかもあったらぜひください。