マクロを除いた配布用ブックを作成する。

マクロを使って作成したブックを配布段階でマクロを除くという作業を自動化します。
これは最近、多く質問をいただく案件です。 昨今はセキュリティ機能が向上してきたものの、そのために不必要な警告メッセージが表示されたりするものです。 Excelでもマクロが入っているだけで、いちいち警告表示が出たりしますが、処理済みのマクロがそのまま配布するExcelブックに残っているだけということも多いようです。 ここで質問をいただく方は既に気付かれているわけですが、配布前に自動的にマクロを削除する方法はないものかと考えているわけです。 「今回だけ」であれば手作業で削除すれば良いわけですが、毎月、毎週、毎日の定例業務であればそうはいきません。
マクロが標準モジュールだけなら、シートを新規ブックにコピーさせるだけで良いのです。
この方法では、標準モジュールは新規ブック側にはコピーされません。シートモジュールにイベントなどのコード記述がないなら、そのシートを新規ブックにコピーさせればコピー先のブックにはマクロはないことになります。
マクロを除いて新規ブックを作成
配布用に転出させるシートはこのサンプルの場合、「Sheet1」「Sheet2」「Sheet3」の3つとしてあります。 このように1シートに限定されることもなく、それほど複雑にもならないコードでマクロがない配布用のブックの作成が可能です。

'*******************************************************************************
'   新規ブックをマクロなしで作成するサンプル
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit

'*******************************************************************************
'   新規ブックをマクロなしで作成するサンプル
'*******************************************************************************
Sub MAKE_NEWBOOK_WO_MACROS()
    Const cnsTITLE = "マクロなしブックの作成"
    Const cnsFILTER = "Excelワークブック (*.xls),*.xls"
    Dim xlAPP As Application
    Dim WBK1 As Workbook                    ' 本ブック
    Dim WBK2 As Workbook                    ' 作成ブック
    Dim strFILENAME As String
    Dim tblSH As Variant
    Dim lngLines As Long

    ' 新規ブックに転出するシートの配列を作成
    tblSH = Array("Sheet1", "Sheet2", "Sheet3")

    Set xlAPP = Application
    Set WBK1 = ThisWorkbook                 ' 本ブック
    ' 「名前を付けて保存」のフォームでファイル名の指定を受ける
    xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
    strFILENAME = xlAPP.GetSaveAsFilename(InitialFilename:="SAMPLE.xls", _
        FileFilter:=cnsFILTER, Title:=cnsTITLE)
    ' キャンセルされた場合は以降の処理は行なわない
    If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
    If strFILENAME = WBK1.FullName Then
        MsgBox "本ブックとは違うファイル名を指定して下さい。",, cnsTITLE
        GoTo MAKE_NEWBOOK_WO_MACROS_EXIT
    End If
    ' 指定シート(複数)を新規ブックにコピーする
    WBK1.Worksheets(tblSH).Copy
    Set WBK2 = ActiveWorkbook               ' コピーした新規ブック
    ' 処理ブックを保存
    WBK2.SaveAs Filename:=strFILENAME
    WBK2.Close False
    Set WBK2 = Nothing
MAKE_NEWBOOK_WO_MACROS_EXIT:
    Set WBK1 = Nothing
    Set xlAPP = Nothing
End Sub

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

シートモジュールにマクロがある場合は、削除するしかありません。
一方、配布に要するシート自体にイベントなどのコードが記述されている場合は、そのままコピーさせるとシートモジュールのコードも作成ブックにコピーされてしまします。
マクロを除いて新規ブックを作成
この場合は、新規ブック作成後、そのブックを保存させる前にプロジェクトを開いてコードを削除させるしかありません。 この場合、コピー先は新規ブックなのでプロジェクトは保護されておらず、この問題には直面しませんが、Excelのバージョンのよってはこのコード自体が動作しないことがあります。

'*******************************************************************************
'   新規ブックをマクロなしで作成するサンプルA
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit

'*******************************************************************************
'   新規ブックをマクロなしで作成するサンプルA
'*******************************************************************************
Sub MAKE_NEWBOOK_WO_MACROS()
    Const cnsTITLE = "マクロなしブックの作成"
    Const cnsFILTER = "Excelワークブック (*.xls),*.xls"
    Dim xlAPP As Application
    Dim WBK1 As Workbook                    ' 本ブック
    Dim WBK2 As Workbook                    ' 作成ブック
    Dim objVBCOMPO As Object
    Dim strFILENAME As String
    Dim tblSH As Variant
    Dim lngLines As Long

    ' 新規ブックに転出するシートの配列を作成
    tblSH = Array("Sheet1", "Sheet2", "Sheet3")

    Set xlAPP = Application
    Set WBK1 = ThisWorkbook                 ' 本ブック
    ' 「名前を付けて保存」のフォームでファイル名の指定を受ける
    xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
    strFILENAME = xlAPP.GetSaveAsFilename(InitialFilename:="SAMPLE.xls", _
        FileFilter:=cnsFILTER, Title:=cnsTITLE)
    ' キャンセルされた場合は以降の処理は行なわない
    If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
    If strFILENAME = WBK1.FullName Then
        MsgBox "本ブックとは違うファイル名を指定して下さい。",, cnsTITLE
        GoTo MAKE_NEWBOOK_WO_MACROS_EXIT
    End If
    ' 指定シート(複数)を新規ブックにコピーする
    WBK1.Worksheets(tblSH).Copy
    Set WBK2 = ActiveWorkbook               ' コピーした新規ブック
    ' ↓VBProjectに対するアクセスが許可されていない場合はエラーになります↓
    ' VBProject内の各コンポーネントのコードを削除
    For Each objVBCOMPO In WBK2.VBProject.VBComponents
        With objVBCOMPO.CodeModule
            ' コードを削除(全行)
            lngLines = .CountOfLines
            If lngLines <> 0 Then .DeleteLines 1, lngLines
        End With
    Next objVBCOMPO
    ' 処理ブックを保存
    WBK2.SaveAs Filename:=strFILENAME
    WBK2.Close False
    Set WBK2 = Nothing
MAKE_NEWBOOK_WO_MACROS_EXIT:
    Set WBK1 = Nothing
    Set xlAPP = Nothing
End Sub

'----------------------------<< End of Source >>--------------------------------
Excelの最近のバージョンによっては、このようなマクロからプロジェクト(マクロのコード自体)を操作する記述が「マクロウィルス」と誤認されるため、 Excel上の初期設定や、ウィルス検知ソフトによって、このようなマクロの動作がブロックされる場合があります。

既に作成した複数のマクロ入りExcelブックのマクロを一括撤去してみます。
この手の処理は、掲示板などを見てもご要望が多いものです。ここでは「フォルダの参照」を使ってルートフォルダを指定して、そこから配下のフォルダを含めて順にファイルを探索して、存在するExcelブックを順次開いてマクロの撤去を行ないます。
フォルダを指定して、すべてのブックからマクロを除く
前のサンプル同様に、この手のマクロは初期設定状態ではExcel2002以降では動作しません。

'*******************************************************************************
'   フォルダ内の全Excelブックからマクロを取り除く(含むサブフォルダ)
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
' [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Microsoft Visual Basic for Applications Extensibility x.x
'*******************************************************************************
Option Explicit
Private g_cntFILE As Long       ' 参照ファイル数
Private g_cntFILE2 As Long      ' 更新ファイル数
Private g_cntERROR As Long      ' エラー発生件数
Private g_cntPATH As Long       ' 参照フォルダ数
Private g_xlAPP As Application  ' Excel.Application
Private g_WBK As Workbook       ' 自ブック
Private g_SH0 As Worksheet      ' 自ブックのシート

'*******************************************************************************
'   全体処理(ルートフォルダを指定して探索を開始)
'*******************************************************************************
Sub SEARCH_FOLDER()
    Dim objFSO As FileSystemObject              ' FSO
    Dim strPATHNAME As String

    ' ルートとなるフォルダの指定(※modFolderPicker1.bas)
    strPATHNAME = modFolderPicker1.FolderDialog( _
        "ルートフォルダを指定して下さい。", True)
    If strPATHNAME = "" Then Exit Sub
    ' 処理開始
    Set g_xlAPP = Application
    Set g_WBK = ThisWorkbook
    Set g_SH0 = g_WBK.Worksheets(1)
    ' 画面描画停止
    With g_xlAPP
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    g_SH0.Rows("2:65536").ClearContents
    g_SH0.PageSetup.LeftHeader = "&09 " & strPATHNAME
    Set objFSO = New FileSystemObject           ' FSO
    ' ルートフォルダから探索開始
    Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 2)
    ' 参照OBJECTを破棄
    Set objFSO = Nothing
    ' 処理完了(結果表示)
    Set g_SH0 = Nothing
    ' 画面描画再開
    With g_xlAPP
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .StatusBar = False
        .ScreenUpdating = True
    End With
    Set g_xlAPP = Nothing
    MsgBox "処理が完了しました。" & vbCr & vbCr & _
        "参照フォルダ数=" & g_cntPATH & vbCr & _
        "参照ファイル数=" & g_cntFILE & vbCr & _
        "処理ファイル数=" & g_cntFILE2 & vbCr & _
        "エラー発生件数=" & g_cntERROR, vbInformation
    g_WBK.Saved = True
    Set g_WBK = Nothing
End Sub

'*******************************************************************************
'   フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行,カラム)
'*******************************************************************************
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, _
                              ByRef GYO As Long)
    Dim objPATH2 As Folder
    Dim objFILE As File

    ' ■先ずサブフォルダを探索するループ処理
    For Each objPATH2 In objPATH.SubFolders
        ' フォルダ単位のサブ処理(再帰呼び出し)
        Call SEARCH_SUB_FOLDER(objPATH2, GYO)
    Next objPATH2

    ' 現在フォルダをシート上に表示
    g_cntPATH = g_cntPATH + 1                   ' 参照フォルダ数を加算
    g_SH0.Cells(GYO, 2).Value = objPATH.Path
    ' ■本フォルダの各ファイルをシート上に表示するループ処理
    For Each objFILE In objPATH.Files
        g_cntFILE = g_cntFILE + 1               ' 参照ファイル数
        If ((objFILE.Attributes <> ReadOnly) And _
            (StrConv(Right(objFILE.Name, 4), vbUpperCase) = ".XLS") And _
            (objFILE.Name <> g_WBK.Name)) Then
            ' マクロ削除処理
            Call DELETE_MACROS(objFILE, GYO)
        End If
    Next objFILE
    ' 参照OBJECTを破棄
    Set objPATH = Nothing
End Sub

'*******************************************************************************
'   マクロの削除処理(1ブック単位)
'*******************************************************************************
Private Sub DELETE_MACROS(objFILE As File, ByRef GYO As Long)
    Dim WBK As Workbook                     ' 対象ブック
    Dim objVBP As VBProject
    Dim objVBCOMPO As VBComponent
    Dim strFILENAME As String
    Dim lngLines As Long
    Dim swOPEN As Boolean
    Dim GYO2 As Long

    ' 対象ブックを開く
    On Error GoTo DELETE_MACROS_ERR
    g_cntFILE2 = g_cntFILE2 + 1             ' 更新ファイル数
    strFILENAME = objFILE.Path
    GYO2 = GYO
    g_SH0.Cells(GYO, 1).Value = GYO - 1
    g_SH0.Cells(GYO, 3).Value = objFILE.Name
    g_xlAPP.StatusBar = objFILE.Name & " 処理中...."
    g_xlAPP.ScreenUpdating = False
    Set WBK = Workbooks.Open(strFILENAME, False, False)
    swOPEN = True
    ' ↓VBProjectに対するアクセスが許可されていない場合はエラーになります↓
    ' VBProject内の各コンポーネントのコードを削除
    Set objVBP = WBK.VBProject
    For Each objVBCOMPO In objVBP.VBComponents
        g_SH0.Cells(GYO, 1).Value = GYO - 1
        g_SH0.Cells(GYO, 4).Value = objVBCOMPO.Name
        If objVBCOMPO.Type = 100 Then
            ' ThisWorkbook,Worksheet(解放不可なので全行削除)
            With objVBCOMPO.CodeModule
                ' コードを削除(全行)
                lngLines = .CountOfLines
                If lngLines <> 0 Then
                    .DeleteLines 1, lngLines
                    g_SH0.Cells(GYO, 5).Value = "○(DeleteLines)"
                Else
                    g_SH0.Cells(GYO, 5).Value = "Skip(マクロなし)"
                End If
            End With
        Else
            ' 標準モジュール,クラスモジュールは解放
            objVBP.VBComponents.Remove objVBCOMPO
            g_SH0.Cells(GYO, 5).Value = "○(Remove)"
        End If
        GYO = GYO + 1                       ' 行を加算
    Next objVBCOMPO
    ' 処理ブックを保存
    WBK.Save
    WBK.Close False
    Set WBK = Nothing
    g_xlAPP.ScreenUpdating = True
    If GYO = GYO2 Then GYO = GYO + 1        ' 行を加算
    Exit Sub

'-------------------------------------------------------------------------------
' 実行時エラー処置(シートに状況を表示)
DELETE_MACROS_ERR:
    g_cntERROR = g_cntERROR + 1
    g_SH0.Cells(GYO, 5).Value = "エラー(" & Err.Description & ")"
    GYO = GYO + 1
    If swOPEN = True Then
        ' Open以後のエラーの場合は、非保存で閉じる
        WBK.Saved = True
        WBK.Close False
    End If
    Set WBK = Nothing
End Sub

'----------------------------<< End of Source >>--------------------------------
再帰動作による階層を含めたフォルダの参照については、「フォルダ内のファイル一覧の取得」の2番目で紹介しているコードを利用しています。その中のファイルを参照するループ処理の中で拡張子が「XLS」かを判断して、「DELETE_MACROS」プロシージャを呼び出しています。この処理自体は再起動作の対象ではないので「ByVal」を明示しない呼び出し方で、FSO(FileSystemObject)の「File」と、処理結果を表示させるための「行」を引数としています。
DELETE_MACROS」プロシージャ内では、「File」からフルパスのファイル名を取りだして「Open」メソッドに掛けているので、実際はフルパスのファイル名を引数にして利用しても良いことになります。
エラー処置をしているのは、Excel2002以降の問題や、VBプロジェクトがパスワード保護されている場合などでエラーとなるためですが、それ以外のフォルダセキュリティなどについてはコードが複雑になるだけなのでこのサンプルでは割愛しています。