他ブックのソースコードを一括置換する方法【Excel VBA】

VBAでドキュメント自動生成などをしていると、ある時ふと新規作成したドキュメントにちょっとしたモジュールを仕込みたいなとか思ったりしませんか？

アドインでいいじゃんと思うかもしれませんが、アドインにするなら全てのブックおよびシートで同じ動作をするようなものでないとやりにくいです。

何かの拍子に誤って押してドキュメントぐちゃぐちゃになったら嫌ですよね？

特定のドキュメントで特定の処理をさせたいんですよ。

そんな限定的ではあるものの、小回りのきく方法でやっていきたいと思います。

具体的には、CodeModuleプロパティで最新ソースコードを読み込み、他のブックのモジュールと照合し、置換します。

対象は、シートモジュール、標準モジュール、クラスモジュールのソースコードです。

1 書き換えに使用するマクロの例
2 ソースコード
3 参照設定
4 検証環境
5 ダウンロード

書き換えに使用するマクロの例

新規ブックを作成して、下記のようなマクロを記載しました。

一見、何の変哲もないマクロですが、十字カーソルを条件付き書式で行うという便利マクロです。

Option Explicit
Sub CrossCursorOn()
  Call CrossCursorOff
  
  With ThisWorkbook.ActiveSheet
   With .Cells
     '条件付き書式の設定（擬似的な十字カーソル）
     .FormatConditions.Add Type:=xlExpression, Operator:=xlEqual, _
       Formula1:="=OR(CELL(""row"")=ROW(),CELL(""col"")=COLUMN())"
     
     With .FormatConditions(.FormatConditions.Count).Interior
       .Pattern = xlSolid
       .PatternColorIndex = xlAutomatic
       .ThemeColor = xlThemeColorAccent2
       .TintAndShade = 0.8
       .PatternTintAndShade = 0
     End With
     
     .FormatConditions(.FormatConditions.Count).StopIfTrue = False
   End With
  End With
End Sub

Sub CrossCursorOff()
  ThisWorkbook.ActiveSheet.Cells.FormatConditions.Delete
End Sub

実際使用する際は、該当のシートモジュールに以下を追加する必要があります。選択セルを変えると画面更新するもので、先ほどのマクロと連携して動作します。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.ScreenUpdating = True
End Sub

ボタンを追加する時も自動化すると便利です。

既存ブックにあるボタンを別ブックにコピーすると、そのボタンが既存ブックと紐ついてしまうので、設置用のマクロ組みましょう。

先ほどのシートモジュールに記載します。これで、シートをアクティブした時や選択セルを変えた時にボタン追加されます。

Option Explicit
Private Sub Worksheet_Activate()
  Call Add_Button
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Call Add_Button
  Application.ScreenUpdating = True
End Sub

Private Sub Add_Button()
  With ActiveSheet
    If .Buttons.Count > 0 Then Exit Sub
    With .Cells(3, 3)
      With ActiveSheet.Buttons.Add(.Left, .Top, .Width * 2, .Height * 2)
        .OnAction = "CrossCursorOn"
        .Characters.Text = "CursorOn"
        .Font.Name = "Meiryo UI"
        .Font.Size = 9
      End With
    End With
    With .Cells(3, 6)
      With ActiveSheet.Buttons.Add(.Left, .Top, .Width * 2, .Height * 2)
        .OnAction = "CrossCursorOff"
        .Characters.Text = "CursorOff"
        .Font.Name = "Meiryo UI"
        .Font.Size = 9
      End With
    End With
  End With
End Sub

ソースコード

では、先ほどのマクロで実際に書き換えていきましょう。

今回も、ファイル一覧を作成し、一括･個別どちらもできるようにしました。

本記事の下部で完成版をダウンロードできますので、ご活用ください。

使い方

置換マクロブックに先ほどの紹介した置換用マクロを指定します。
モジュール読込ボタンを押下します。
モジュール一覧に登録されるので、ドロップダウンリストから特定のモジュールを選択（※選択せず、空白にするとALL指定=全選択となります。)
置換するボタンか一括ボタンを押下でマクロ置換を実行します。

流れとしては、

マクロを挿入･置換したいブックを開く
既存ソースコードを消して、新ソースコード挿入となります。(置換)

※ソースコードを消す時は、同じモジュール名のものが対象です。見つからない場合は、新しくモジュール追加という形になります。

　（シートモジュール指定の場合に、反映先にシートが見つからない時、強制的に新規シート追加しようと思ったんですが必要ないかと思ってコメント化しました。）

※プロシージャReplace_Module_Allの引数PRAM_TYPEは、0：一括、１：個別です。

Option Explicit
Sub Replace_Module_All(ByVal PRAM_TYPE As Integer)
  Dim OpenFile     As String
  Dim ReplaceBook   As Workbook
  Dim ReplaceModule As String
  Dim Sta_Row      As Long
  Dim End_Row      As Long
  Dim Cnt          As Long: Cnt = 1
  Dim End_Cnt      As Long
  Dim i            As Long
  Dim msg          As String
  
  On Error GoTo Err_Exit
  
  With ThisWorkbook.ActiveSheet
    '一括
    If PRAM_TYPE = 0 Then
      Sta_Row = 11
      End_Row = .Cells(Rows.Count, 2).End(xlUp).Row
      End_Cnt = End_Row - Sta_Row - 1
    Else
    '個別
      Sta_Row = ActiveCell.Row
      End_Row = ActiveCell.Row
      End_Cnt = 1
    End If
    
    If Sta_Row > End_Row Then GoTo Err_Exit
    
    Application.StatusBar = "処理中です..."
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    Application.Calculation = xlCalculationManual
    Application.EnableCancelKey = xlErrorHandler
    
    OpenFile = .Cells(6, 2).Value
    ReplaceModule = Trim(.Cells(8, 2).Value)
    
    If Trim(OpenFile) <> "" Then
      Application.EnableEvents = False
      Set ReplaceBook = Workbooks.Open(FileName:=OpenFile, ReadOnly:=True, Notify:=False)
      Application.EnableEvents = True
    Else
      MsgBox "置換マクロが選択されていません｡" & Err.Number, vbCritical, "エラー"
      GoTo Err_Exit
    End If
    
    If Err.Number <> 0 Then GoTo Err_Exit
                
    For i = Sta_Row To End_Row
      DoEvents
      OpenFile = .Cells(i, 2) & "" & .Cells(i, 3)
      Call Replace_Module(OpenFile, ReplaceBook, ReplaceModule, msg)
      
      .Cells(i, 7).Value = msg
      
      If Err.Number = 18 Then
        GoTo Err_Exit
      End If
      
      Application.StatusBar = "処理中です...（" & Cnt & "／" & End_Cnt & "）"
      Cnt = Cnt + 1
    Next
  End With
  
Err_Exit:
  ReplaceBook.Close False
  
  Application.StatusBar = False
  Application.ScreenUpdating = True
  Application.Cursor = xlDefault
  Application.Calculation = xlCalculationAutomatic
  Application.EnableCancelKey = xlInterrupt
    
  If Err.Number <> 0 Then
    If Err.Number = 18 Then
      Application.StatusBar = "中断しました。"
    Else
      MsgBox "予期せぬエラー" & Err.Number, vbCritical, "エラー"
    End If
  Else
    MsgBox "処理完了しました。"
  End If
End Sub

Sub Replace_Module(ByVal OpenFile As String, ByVal ReplaceBook As Workbook, _
                   ByRef ReplaceModule As String, ByRef msg As String)
  Dim TargetBook   As Workbook
'  Dim TargetSheet  As Worksheet
  Dim TargetName   As String
  Dim ReplaceCode  As String
  Dim ReplaceType  As Integer
  Dim ReplaceName  As String
  Dim i As Long, j As Long
  Dim FileType     As String
  Dim ProcMode     As String
  
  If OpenFile = ReplaceBook.FullName Then
    msg = "Replace File"
    Exit Sub
  End If
  
  Select Case True
    Case StrConv(LCase(OpenFile), vbNarrow) Like "*.xlsm"
      FileType = "xlsm"
    Case StrConv(LCase(OpenFile), vbNarrow) Like "*.xlam"
      FileType = "xlam"
    Case Else
      msg = "SKIP"
      Exit Sub
  End Select
  
  On Error GoTo Err_Exit
  
  Application.EnableEvents = False
  
  Set TargetBook = Workbooks.Open(FileName:=OpenFile, ReadOnly:=False, Notify:=False)
    
  If Err.Number <> 0 Then GoTo Err_Exit
  
  If ReplaceModule = "" Then
    ProcMode = "ALL_MODULE"
  Else
    ProcMode = "ONE_MODULE"
  End If

  With ReplaceBook.VBProject
    For i = .VBComponents.Count To 1 Step -1
      If ProcMode = "ALL_MODULE" Then
        If .VBComponents(i).Type = 1 Or .VBComponents(i).Type = 2 Or _
           (FileType = "xlsm" And .VBComponents(i).Type = 100) Then
          With .VBComponents(i)
            With .CodeModule
              If .CountOfLines > 0 Then
                ReplaceCode = .Lines(1, .CountOfLines)
              End If
            End With
            ReplaceModule = .Name
            ReplaceType = .Type
            ReplaceName = .Properties("name").Value
          End With
        Else
          GoTo NextModule
        End If
      Else
        With ReplaceBook.VBProject
          With .VBComponents(ReplaceModule)
            With .CodeModule
              If .CountOfLines > 0 Then
                ReplaceCode = .Lines(1, .CountOfLines)
              End If
            End With
            ReplaceType = .Type
            ReplaceName = .Properties("name").Value
          End With
        End With
        If Err.Number <> 0 Then GoTo Err_Exit
      End If
      
      If Err.Number <> 0 Then GoTo Err_Exit
      
      With TargetBook.VBProject
        For j = .VBComponents.Count To 1 Step -1
          With .VBComponents(j)
            TargetName = .Properties("name").Value
            If ((.Type = 1 Or .Type = 2) And .Name = ReplaceModule) Or _
               (.Type = 100) And TargetName = ReplaceName Then
              With .CodeModule
                If .CountOfLines > 0 Then
                  .DeleteLines 1, .CountOfLines
                End If
                .AddFromString ReplaceCode
                GoTo NextModule
              End With
            End If
            If Err.Number <> 0 Then GoTo Err_Exit
          End With
        Next
        If ReplaceType <= 3 Then
          With .VBComponents.Add(ReplaceType)
            .CodeModule.AddFromString ReplaceCode
            .Name = ReplaceModule
          End With
        Else
          msg = "シートが見つかりません｡"
'          With TargetBook
'            Set TargetSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))
'            TargetSheet.Name = ReplaceName
'          End With
'          .VBComponents(TargetSheet.CodeName).CodeModule.AddFromString ReplaceCode
        End If
      End With
NextModule:
      If ProcMode = "ALL_MODULE" Then
      Else
        Exit For
      End If
    Next
  End With
  
  If Err.Number <> 0 Then GoTo Err_Exit
  
  TargetBook.Close True
'  Set TargetSheet = Nothing
  Application.EnableEvents = True
  msg = "Replace OK"
  
  Exit Sub
  
Err_Exit:
  TargetBook.Close False
'  Set TargetSheet = Nothing
  Application.EnableEvents = True
  msg = "Replace Err"
End Sub

Sub Read_Module()
  Dim OpenFile     As String
  Dim ReadBook     As Workbook
  Dim WS           As Worksheet
  Dim i As Long, j As Long
  
  On Error GoTo Err_Exit
 
  With ThisWorkbook.ActiveSheet
    OpenFile = .Cells(6, 2).Value
  End With
  
  Application.StatusBar = "処理中です..."
  Application.ScreenUpdating = False
    
  If Trim(OpenFile) <> "" Then
    Application.EnableEvents = False
    Set ReadBook = Workbooks.Open(FileName:=OpenFile, ReadOnly:=True, Notify:=False)
    Application.EnableEvents = True
  Else
    MsgBox "置換マクロが選択されていません｡" & Err.Number, vbCritical, "エラー"
    GoTo Err_Exit
  End If
  
  Set WS = ThisWorkbook.Sheets("モジュール一覧")
  j = 2
  
  If Err.Number <> 0 Then GoTo Err_Exit
  
  Call DataClear(j, WS.Name)
  
  With ReadBook.VBProject
    For i = 1 To .VBComponents.Count
      If .VBComponents(i).Type = 1 Or _
         .VBComponents(i).Type = 2 Or _
         .VBComponents(i).Type = 100 Then
        With .VBComponents(i)
          WS.Cells(j, 1).Value = .Name
          WS.Cells(j, 2).Value = .Type
          WS.Cells(j, 3).Value = .Properties("name").Value
          With .CodeModule
            WS.Cells(j, 4).Value = .CountOfLines
          End With
        End With
      j = j + 1
      End If
    Next
  End With
    
Err_Exit:
  ReadBook.Close False
  
  Application.StatusBar = False
  Application.ScreenUpdating = True
    
  If Err.Number <> 0 Then
    MsgBox "予期せぬエラー" & Err.Number, vbCritical, "エラー"
  Else
    MsgBox "処理完了しました。"
  End If
End Sub

VBComponentsのNameプロパティはモジュール名なので

シート名を確認したい時は、 VBComponents(n).Properties("name").Valueのように取得します。

参照設定

使用する場合は、以下参照設定が必要です。

(開発タブ>Visual Basic>ツール(T)>参照設定)

１） Microsoft Scripting Runtime

２） Windows Script Host Object Model ※ファイル一覧作成時に使用

３）Microsoft Visual Basic for Application Extensibility x.x

さらに、ファイル＞オプション＞セキュリティセンター(タブ)＞セキュリティセンターの設定＞マクロの設定＞VBAプロジェクトオブジェクトモデルへのアクセスを信頼するにチェックが必要です。

検証環境

Microsoft Office Excel 2016で検証しています。

ダウンロード

サンプルプログラムはこちらからダウンロードできます。

※ 本ファイルを利用して発生したいかなる損害について、著作者はその結果について一切の責任を負わないものとします。

sample_Replace_Module_All ダウンロード