openpyxlでPermissionError例外を出しちゃう人のための別名保存マクロ(VBA)

Pythonでopenpyxl を使ったコードを書いているとよく出くわすPermissionError例外。
openpyxlで開こうとしているファイルをExcelで編集しているときにでる例外ですが、Python側でreadonly指定していても出るのが痛いところ。

要はExcelでファイルをちゃんと閉じてからスクリプトを実行すればいいんだけど、値変えたりして試行錯誤しながらコードを書いていると地味に忘れがちだし面倒くさい。

解決策としては、編集中のExcelファイルを別名保存して、その別名の方をopenpyxlで開いて試行錯誤する方法が考えられるのですが、別名で保存すると元ファイルが閉じられて保存した別名のほうが開いている状態になってしまいます。

そこで、「編集中のExcelファイルを別名保存して、別名保存前のファイルを再度開いて保存後のほうのファイルを閉じる」というマクロをVBAで書いたのでシェアします。openpyxlで別名の方を開けばPermissionError例外に悩むことなくコーディングに集中できます。

個人用マクロファイルに入れてクイックアクセスツールバーに登録して使うという使い方を想定しています。バグなど見つけた方は編集リクエストください。

sample.bas

Option Explicit
Sub ReOpenAfterBackup()
'
' 現在編集中のファイルを同じフォルダに別名で保存した後に現在のファイルを開きなおす
' 別名は、[編集中のファイル名の拡張子の前の部分]+ suffix+拡張子。上書き。
' 現ファイルが前回保存から変更ありの場合は問答無用で上書き保存する
' ファイル名がない場合(未保存)の場合は終了
'
    Const suffix As String = "_bk"      '自由に変更してください
    Dim fso As FileSystemObject
    Dim curFileName As String           '編集中ファイル名(パスなし)
    Dim newFileName As String           '別名ァイル名(パスなし)
    Dim absCurFileName As String        '編集中ファイル名(フルパス)
    Dim absNewFileName As String        '別名ァイル名(フルパス)
    Dim saveDir As String               '保存先(編集中ファイルの場所)
    Dim baseName As String              '編集中ファイルの拡張子の前の部分
    Dim extension As String             '編集中ファイルの拡張子
    
    ' 現在開いているブックが未保存(book1など)の場合は終了
    saveDir = ActiveWorkbook.Path
    If saveDir = "" Then
        MsgBox ("ファイルを保存してから実行してください")
        Exit Sub
    End If
    
    ' 現在開いているブックのファイル名を取得して保存するファイル名を決定する
    curFileName = ActiveWorkbook.Name
    absCurFileName = saveDir & "\" & curFileName
    
    Set fso = New FileSystemObject  'レアなので失敗時処理は省略
    baseName = fso.GetBaseName(curFileName)
    extension = fso.GetExtensionName(curFileName)
    Set fso = Nothing
    
    newFileName = baseName & suffix & "." & extension
    absNewFileName = saveDir & "\" & newFileName
            
    '以下の設定については元に戻す処理を省略(終了時自動でTrueになる)
    Application.ScreenUpdating = False 'ちらつき防止
    Application.DisplayAlerts = False  '上書き保存時の警告を出さない
           
    On Error GoTo ErrorHandler
        ' 編集中のファイルを上書き保存後、別名で保存する
        Workbooks(curFileName).Save
        Workbooks(curFileName).SaveAs fileName:=absNewFileName
        
        ' 元ファイルを開いて別名ファイルを閉じる
        Workbooks.Open fileName:=absCurFileName
        Workbooks(newFileName).Close
    On Error GoTo 0
    
    Exit Sub
    
ErrorHandler:
    MsgBox ("ファイルの保存・再オープンに失敗しました")
    Exit Sub
End Sub