VBA

マクロを他のブックに一括で自動インポート&エクスポート【Excel VBA】

2019-10-20

複数のマクロブックで同じモジュールを使いまわしたい時、いちいち手動エクスポート/インポートするのは面倒ですよね。

今回は、標準モジュール、クラスモジュール、ユーザーフォームを一括で自動エクスポート/インポートしたいかなと思います。

ちなみに、VBProject.VBComponents.CodeModuleを使ってエクスポートなしでマクロを書き換えるという荒業もできます。

ソースコード

画面イメージは以下のような感じです。

 ファイル一覧上のファイルに指定ファイルをインポート(個別・一括)または、

 ファイル一覧上のファイルのモジュールをエクスポート(個別・一括)します。

クリックすると別ウィンドウで拡大 表示する

※ファイル一覧の作成については、以下の記事で解説しています。

関連記事サブフォルダ含むファイル一覧を高速に取得・作成【Excel VBA】

プロシージャImport_And_Exportに引数:処理タイプを渡して起動します。

  • PRAM_TYPE :0・・・ 一括インポート
  • PRAM_TYPE :1・・・ 個別インポート
  • PRAM_TYPE :2・・・ 一括エクスポート
  • PRAM_TYPE :3・・・ 個別エクスポート

さらに変数OpenFileに渡された文字列がファイルかフォルダかで以下のように分岐します。

インポート時:

 ファイルなら自動エクスポート/インポートとなり、

 フォルダならエクスポート済みとして扱い自動インポートのみ処理します。

エクスポート時:

 ファイルなら自動エクスポートのみ行います。

 フォルダの文字列を渡すことはありません。

※インポート時は、同じ名前のモジュールはRemove/Import(最新に置換)し、新しいモジュールは単純にImportします。

※エクスポート先は、エクスポート対象のファイルと同フォルダに

yyyymmdd_(ファイル名)_(拡張子)というフォルダを生成して、そこに格納します。

標準モジュール:

Option Explicit
Sub Import_And_Export(ByVal PRAM_TYPE As Integer)
  Dim FSO          As New Scripting.FileSystemObject
  Dim OpenFile     As String
  Dim ExportBook   As Workbook
  Dim ExportFolder As String
  Dim ExportFiles  As Collection
  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 Or PRAM_TYPE = 2 Then
      Sta_Row = 10
      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
    
    '個別・一括インポート
    If PRAM_TYPE = 0 Or PRAM_TYPE = 1 Then
      OpenFile = .Cells(6, 2).Value
      'エクスポート処理
      Call Export_Module(FSO, OpenFile, ExportBook, ExportFolder, msg)
    Else
    '個別・一括エクスポート
      For i = Sta_Row To End_Row
        DoEvents
        OpenFile = .Cells(i, 2) & "" & .Cells(i, 3)
        Call Export_Module(FSO, OpenFile, ExportBook, ExportFolder, msg)
        
        If ThisWorkbook.FullName <> ExportBook.FullName Then
          ExportBook.Close False
        End If
        
        .Cells(i, 8).Value = msg
      
        If Err.Number = 18 Then
          GoTo Err_Exit
        End If
      
        Application.StatusBar = "処理中です...(" & Cnt & "/" & End_Cnt & ")"
        Cnt = Cnt + 1
      Next
    End If
    
    If Err.Number <> 0 Then GoTo Err_Exit
    
    If PRAM_TYPE = 0 Or PRAM_TYPE = 1 Then
      'インポート
    Else
      'エクスポート
      GoTo Err_Exit
    End If
    
    With New VBAProject.cmdFileList
      Set ExportFiles = .getFileList(1, ExportFolder, "*.bas,*.cls,*.frm").Files
      
      If ExportFiles.Count > 0 Then
      Else
        GoTo Err_Exit
      End If
    End With
    
    For i = Sta_Row To End_Row
      DoEvents
      OpenFile = .Cells(i, 2) & "" & .Cells(i, 3)
      Call Import_Module(FSO, OpenFile, ExportBook, ExportFiles, msg)
      
      .Cells(i, 8).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:
    If PRAM_TYPE = 0 Or PRAM_TYPE = 1 Then
      If ThisWorkbook.FullName <> ExportBook.FullName Then
        ExportBook.Close False
      End If
    End If
    
    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 Import_Module(ByVal FSO As Scripting.FileSystemObject, ByVal OpenFile As String, _
                  ByVal ExportBook As Workbook, ByVal ExportFiles As Collection, ByRef msg As String)
  Dim ImportBook As Workbook
  Dim f          As Scripting.File
  Dim i          As Long
  
  If OpenFile = ExportBook.FullName Then
    msg = "Import File"
    Exit Sub
  End If
  
  If StrConv(LCase(OpenFile), vbNarrow) Like "*.xlsm" Or _
     StrConv(LCase(OpenFile), vbNarrow) Like "*.xlam" Then
  Else
    msg = "SKIP"
    Exit Sub
  End If
  
  On Error GoTo Err_Exit
  
  Application.EnableEvents = False
  
  Set ImportBook = Workbooks.Open(FileName:=OpenFile, ReadOnly:=False, Notify:=False)
  
  If Err.Number <> 0 Then GoTo Err_Exit
  
  With ImportBook.VBProject
    For Each f In ExportFiles
      For i = .VBComponents.Count To 1 Step -1
        If .VBComponents(i).Type >= 1 And .VBComponents(i).Type <= 3 And _
           .VBComponents(i).Name = FSO.GetBaseName(f.Name) Then
          .VBComponents.Remove .VBComponents(i)
        End If
        If Err.Number <> 0 Then GoTo Err_Exit
      Next
      
      .VBComponents.Import f.Path
      If Err.Number <> 0 Then GoTo Err_Exit
    Next
  End With
  
  ImportBook.Close True
  Application.EnableEvents = True
  msg = "Import OK"
  
  Exit Sub
  
Err_Exit:
  ImportBook.Close False
  Application.EnableEvents = True
  msg = "Import Err"
End Sub

Sub Export_Module(ByVal FSO As Scripting.FileSystemObject, ByVal OpenFile As String, _
                  ByRef ExportBook As Workbook, ByRef ExportFolder As String, ByRef msg As String)
  Dim VBA As VBComponent
  Dim ext As String
  
  On Error GoTo Err_Exit
  
  If GetAttr(OpenFile) = vbDirectory Then
    'エクスポート済み
    Set ExportBook = ThisWorkbook
    ExportFolder = OpenFile
    Exit Sub
  End If
  
  Application.EnableEvents = False
  
  If Trim(OpenFile) <> "" Then
    Set ExportBook = Workbooks.Open(FileName:=OpenFile, ReadOnly:=True, Notify:=False)
  Else
    Set ExportBook = ThisWorkbook
  End If
  
  Application.EnableEvents = True
    
  If Err.Number <> 0 Then GoTo Err_Exit
    
  With FSO
    ExportFolder = .GetParentFolderName(ExportBook.FullName) & "" & _
                   Format(Date, "yyyymmdd") & "_" & _
                   .GetBaseName(ExportBook.Name) & "_" & _
                   .GetExtensionName(ExportBook.Name)
  End With

  If ExportBook.Path = ExportFolder Then
    Err.Raise (18)
    GoTo Err_Exit
  End If

  If Dir(ExportFolder, vbDirectory) = "" Then
    Call MkDir(ExportFolder)
  Else
    Call Kill(ExportFolder & "*")
  End If
  
  For Each VBA In ExportBook.VBProject.VBComponents
    Select Case VBA.Type
      Case 1
        ext = ".bas"
      Case 2
        ext = ".cls"
      Case 3
        ext = ".frm"
      Case Else
        GoTo Next_Module
    End Select
    
    VBA.Export ExportFolder & "" & VBA.Name & ext
    
Next_Module:
  Next
  
  msg = "Export OK"
  
  Exit Sub
  
Err_Exit:
  msg = "Export Err"

End Sub

参照設定

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

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

1) Microsoft Scripting Runtime

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

3)Microsoft Visual Basic for Application Extensibility x.x

クリックすると別ウィンドウで拡大 表示する

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

検証環境

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

ダウンロード

配信は停止いたしました。ご利用いただきありがとうございました。

-VBA
-

© 2021 ReiCodeBlog