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

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

目次

まずはコード紹介

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

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 で日本語入力できないため。英文法メチャクチャで恥ずかしいから、なるべく個々の関数を簡素に作って、簡単な単語で伝わるようにした…。

以降、説明。

このマクロがやれること

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

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

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

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 マクロになった。

他に課題とか

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

以上

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

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