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

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