マクロを使って作成したブックを配布段階でマクロを除くという作業を自動化します。

処理結果シートだけが表示されるブックです。

サンプルはこんな感じです。

(この画像をクリックすると、このページのサンプルがダウンロードができます。)
これは実行結果を表示するためのシートです。



マクロの起動は、ボタン等は設けていないので「マクロ」から「SaveWithoutMacros」を実行させて下さい。
最初にルートフォルダの指定画面が表示されます。

本処理はこの「ルートフォルダ」で指定されたフォルダを起点に、配下のサブフォルダを含めて各「マクロ有効ブック(*.xls,*.xlsm,*.xlsb)」を一括して「マクロなしブック(*.xlsx)」として保存し直します。 処理結果はシート上に表示されます。
ここで「ルートフォルダ」を指定して「OK」をクリックすると処理が開始されます。



このサンプルのままだと、元ファイルである「マクロ有効ブック(*.xls,*.xlsm,*.xlsb)」はそのまま残ります。



保存する「マクロなしブック(*.xlsx)」の方は、同じファイル名のファイルが存在する場合は上書きされますが、ファイルが使用中だったり、開くワークブックがパスワード付きだったりと、エラーになる条件もあります。 エラーがあった場合はエラーメッセージが処理結果のD列に表示されます。

それではソースコードです。

'***************************************************************************************************
'   フォルダ内の全Excelブックからマクロを取り除く                   Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'05/09/23(1.00)新規作成
'14/11/03(1.01)修正等
'20/03/03(1.10)*.xlsm化、他(*.xlsx形式保存に変更)
'***************************************************************************************************
Option Explicit

'***************************************************************************************************
'   ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：SaveWithoutMacros
'* 機能　　：フォルダ内の全Excelブックからマクロを取り除く(サブフォルダ含む)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2005年09月23日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：サンプルのためブック処理時以外は実行時エラーに対する対応は行なっていません
'***************************************************************************************************
Sub SaveWithoutMacros()
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objSh0 As Worksheet                                         ' 自ブックのシート
    Dim lngRow As Long                                              ' シート上の行
    Dim cntPath As Long                                             ' 参照フォルダ数
    Dim cntFile1 As Long                                            ' 参照ファイル数
    Dim cntFile2 As Long                                            ' 更新ファイル数
    Dim cntError As Long                                            ' エラー発生件数
    Dim strRootFolder As String                                     ' ルートフォルダ
    '-----------------------------------------------------------------
    ' ルートとなるフォルダの指定(※modFolderPicker2.bas)
    strRootFolder = modFolderPicker2.FolderDialog("ルートフォルダを指定して下さい。")
    ' 未選択(キャンセル)は終了
    If strRootFolder = "" Then Exit Sub
    '-----------------------------------------------------------------
    ' 処理開始
    Set objSh0 = ThisWorkbook.Worksheets(1)
    ' 処理結果シートクリア
    lngRow = 1
    objSh0.Rows("2:" & objSh0.Rows.Count).ClearContents
    objSh0.PageSetup.LeftHeader = "&09 " & strRootFolder
    Set objFso = New FileSystemObject
    '-----------------------------------------------------------------
    ' ルートフォルダから探索開始(フォルダ単位処理)
    Call GP_FolderProc(objFso, _
                       objSh0, _
                       objFso.GetFolder(strRootFolder), _
                       lngRow, _
                       cntPath, _
                       cntFile1, _
                       cntFile2, _
                       cntError)
    '-----------------------------------------------------------------
    ' 参照OBJECTを破棄
    Set objFso = Nothing
    ' 処理結果表示
    MsgBox "処理が完了しました。" & vbCr & vbCr & _
        "参照フォルダ数=" & cntPath & vbCr & _
        "参照ファイル数=" & cntFile1 & vbCr & _
        "処理ファイル数=" & cntFile2 & vbCr & _
        "エラー発生件数=" & cntError, vbInformation
    ' 本ブックは保存済みにする
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'   ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：GP_FolderProc
'* 機能　　：フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = FileSystemObject(Object)
'* 　　　　　Arg2 = 処理結果シート(Object)
'* 　　　　　Arg3 = 現在フォルダ(Object)
'* 　　　　　Arg4 = 処理結果シートの行(Long)            ※Ref参照
'* 　　　　　Arg5 = 参照フォルダ数(Long)                ※Ref参照
'* 　　　　　Arg6 = 参照ファイル数(Long)                ※Ref参照
'* 　　　　　Arg7 = 更新ファイル数(Long)                ※Ref参照
'* 　　　　　Arg8 = エラー発生件数(Long)                ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月27日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：本処理は再帰動作
'***************************************************************************************************
Private Sub GP_FolderProc(ByRef objFso As FileSystemObject, _
                          ByRef objSh0 As Worksheet, _
                          ByVal objFolder As Folder, _
                          ByRef lngRow As Long, _
                          ByRef cntPath As Long, _
                          ByRef cntFile1 As Long, _
                          ByRef cntFile2 As Long, _
                          ByRef cntError As Long)
    '-----------------------------------------------------------------------------------------------
    Dim objSubFolder As Folder                                      ' サブフォルダ
    Dim objFile As File                                             ' ファイル
    Dim strExtU As String                                           ' 拡張子(大文字)
    '-----------------------------------------------------------------
    ' ■先ずサブフォルダを探索するループ
    For Each objSubFolder In objFolder.SubFolders
        ' フォルダ単位処理(再帰呼び出し)
        Call GP_FolderProc(objFso, _
                           objSh0, _
                           objSubFolder, _
                           lngRow, _
                           cntPath, _
                           cntFile1, _
                           cntFile2, _
                           cntError)
    Next objSubFolder
    cntPath = cntPath + 1                                   ' 参照フォルダ数を加算
    '-----------------------------------------------------------------
    ' ■本フォルダの各ファイルを探索するループ
    For Each objFile In objFolder.Files
        cntFile1 = cntFile1 + 1                             ' 参照ファイル数を加算
        ' 拡張子(大文字)を取得
        strExtU = UCase(objFso.GetExtensionName(objFile.Name))
        ' 本ブック以外で対象拡張子(マクロ有効系)か
        If (((strExtU = "XLS") Or (strExtU = "XLSM") Or (strExtU = "XLSB")) And _
            (objFile.Name <> ThisWorkbook.Name)) Then
            cntFile2 = cntFile2 + 1                         ' 更新ファイル数を加算
            ' ファイル単位処理
            If Not FP_FileProc(objFso, objSh0, objFile, objFolder.Path, lngRow) Then
                cntError = cntError + 1                     ' エラー発生件数を加算
            End If
        End If
    Next objFile
    ' 参照OBJECTを破棄
    Set objFolder = Nothing
End Sub

'***************************************************************************************************
'* 処理名　：FP_FileProc
'* 機能　　：ファイル単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = FileSystemObject(Object)
'* 　　　　　Arg2 = 処理結果シート(Object)
'* 　　　　　Arg3 = 現在ファイル(Object)
'* 　　　　　Arg4 = 現在フォルダパス(String)
'* 　　　　　Arg5 = 処理結果シートの行(Long)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月27日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：対象拡張子と判定された以降の処理
'* 注意事項：
'***************************************************************************************************
Private Function FP_FileProc(ByRef objFso As FileSystemObject, _
                             ByRef objSh0 As Worksheet, _
                             ByVal objFile As File, _
                             ByVal strPathname As String, _
                             ByRef lngRow As Long) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim lngPos As Long                                              ' 文字位置
    Dim strSrcFile As String                                        ' 参照ファイル名
    Dim strDstFile As String                                        ' 保存ファイル名
    Dim strErrMSG As String                                         ' エラーメッセージ
    FP_FileProc = False
    lngRow = lngRow + 1
    ' 処理結果シートを更新
    With objSh0
        .Cells(lngRow, 1).Value = lngRow - 1
        .Cells(lngRow, 2).Value = strPathname
        .Cells(lngRow, 3).Value = objFile.Name
    End With
    Application.StatusBar = objFile.Name & " 処理中．．．．"
    '-----------------------------------------------------------------
    ' 参照ファイル名(フルパス)
    strSrcFile = objFile.Path
    ' 拡張子セパレータ位置取得(｢.｣位置)
    lngPos = InStrRev(strSrcFile, ".")
    ' 保存ファイル名の編集(マクロなしブック)
    strDstFile = Left(strSrcFile, lngPos) & "xlsx"
    '-----------------------------------------------------------------
    ' マクロなしブックで保存
    If FP_SaveWithoutMacros(objFso, strSrcFile, strDstFile, strErrMSG) Then
        FP_FileProc = True
    Else
        objSh0.Cells(lngRow, 4).Value = strErrMSG
    End If
End Function

'***************************************************************************************************
'* 処理名　：FP_SaveWithoutMacros
'* 機能　　：マクロなしブックで保存
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = FileSystemObject(Object)
'* 　　　　　Arg2 = 参照ファイル名(String)
'* 　　　　　Arg3 = 保存ファイル名(String)
'* 　　　　　Arg4 = エラーメッセージ(String)            ※Ref参照
'* 　　　　　Arg5 = 参照ファイル削除指示(Boolean)       ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月27日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：パスワード付きブックの対応は行なっていません
'***************************************************************************************************
Private Function FP_SaveWithoutMacros(ByRef objFso As FileSystemObject, _
                                      ByVal strSrcFile As String, _
                                      ByVal strDstFile As String, _
                                      ByRef strErrMSG As String, _
                                      Optional ByVal blnDeleteSrc As Boolean = False) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objWbk As Workbook                                          ' Workbook
    FP_SaveWithoutMacros = False
    On Error GoTo SaveWithoutMacros_ERROR
    ' 画面描画停止
    Application.ScreenUpdating = False
    ' 元ブックを開く
    Set objWbk = Workbooks.Open(strSrcFile, , True)
    ' 警告メッセージを無視
    Application.DisplayAlerts = False
    ' 名前を変更して保存(マクロなしブック)
    objWbk.SaveAs Filename:=strDstFile, FileFormat:=xlOpenXMLWorkbook
    ' 閉じる
    objWbk.Close False
    Set objWbk = Nothing
    ' 参照ファイル削除指示判定
    If blnDeleteSrc Then
        DoEvents
        ' 参照ファイルを削除
        objFso.DeleteFile strSrcFile, True
    End If
    FP_SaveWithoutMacros = True
    GoTo SaveWithoutMacros_EXIT

'===================================================================================================
' エラー処置
SaveWithoutMacros_ERROR:
    strErrMSG = Err.Description

'===================================================================================================
' 終了
SaveWithoutMacros_EXIT:
    ' 警告メッセージを復旧
    Application.DisplayAlerts = True
    ' 画面描画再開
    Application.ScreenUpdating = True
    On Error GoTo 0
End Function

'----------------------------------------<< End of Source >>----------------------------------------

先頭のコラムでも説明しましたが、「マクロを除いた配布用ブック」というのは「マクロなしブック(*.xlsx)」として保存し直すことで目的が達成できます。 昔の「Excel97-2003ブック(*.xls)」の時代は「マクロでマクロ記述を操作する」ようなことをやって、このページにもそのようなサンプルを挙げていたのですが、 現在は「マクロなしブック(*.xlsx)」として保存し直すことでマクロ記述の削除はExcelがやってくれます。



このサンプルではルートフォルダの指定から再帰動作があっての処理なので複雑に見えますが、実際に1つのファイルの「マクロを除いた配布用ブック作成」をやっているのは一番下の「FP_SaveWithoutMacros」だけです。



今回は使用していませんが「FP_SaveWithoutMacros」にはオプションの第5引数があり、ここに「True」を追加すると 変換元だった「マクロ有効ブック(*.xls,*.xlsm,*.xlsb)」の方が削除されるようになっています。