'============================================================
' 改修したブック（=このブック）から、
' 基のブック（元ブック）へ「マクロ（標準モジュール／クラス／ユーザーフォーム）」を移行します。
' ・ThisWorkbook/各Sheetのコード（ドキュメントモジュール）は既定では移行しません
' （イベントのバインド切れ等の事故防止。必要な場合は引数で許可できます）。
' ・「VBAプロジェクトへの信頼」をオンにしてください：
' ファイル > オプション > セキュリティ センター > センターの設定 > マクロの設定 >
' 『VBAプロジェクト オブジェクト モデルへの信頼アクセスを許可する』にチェック。
' ・参照設定は不要（Late Binding）。
'============================================================
Option Explicit
'=== エントリーポイント ======================================
Public Sub 移行を実行()
On Error GoTo EH
Dim tgt As Workbook
Set tgt = PickTargetWorkbook()
If tgt Is Nothing Then
MsgBox "対象ブックが選択されませんでした。処理を中止します。", vbExclamation
Exit Sub
End If
If tgt Is ThisWorkbook Then
MsgBox "このブック自身は対象にできません。別の（基の）ブックを選んでください。", vbExclamation
Exit Sub
End If
Dim movedCount As Long, skippedCount As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
' ドキュメントモジュールは既定で除外（必要なら True に）
CopyAllVBComponents ThisWorkbook, tgt, False, movedCount, skippedCount
Application.EnableEvents = True
Application.ScreenUpdating = True
Dim msg As String
msg = "移行完了：" & movedCount & " 個移行、" & skippedCount & " 個スキップ（ドキュメントモジュール等）。" _
& vbCrLf & "対象ブック：" & tgt.Name
MsgBox msg, vbInformation
Exit Sub
EH:
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "エラーが発生しました：" & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub
'=== 対象ブック選択（推奨：既に開いている元ブックを選ぶ） ===
Private Function PickTargetWorkbook() As Workbook
Dim wb As Workbook, listText As String, n As Long
For Each wb In Application.Workbooks
If Not wb Is ThisWorkbook Then
n = n + 1
listText = listText & n & ": " & wb.Name & vbCrLf
End If
Next
If n > 0 Then
Dim ans As Variant
ans = Application.InputBox( _
Prompt:="移行先（基のブック）を番号で選んでください：" & vbCrLf & listText, _
Title:="基のブックを選択", Type:=1)
If ans = False Then Exit Function
If ans >= 1 And ans <= n Then
Dim idx As Long: idx = 0
For Each wb In Application.Workbooks
If Not wb Is ThisWorkbook Then
idx = idx + 1
If idx = CLng(ans) Then Set PickTargetWorkbook = wb: Exit Function
End If
Next
End If
End If
' 未選択／開いていない場合はファイルダイアログから選択
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "基のブック（移行先）を選択"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel ブック", "*.xls;*.xlsx;*.xlsm;*.xlsb"
If .Show = -1 Then
Dim p As String: p = .SelectedItems(1)
On Error Resume Next
Set PickTargetWorkbook = Workbooks.Open(Filename:=p)
On Error GoTo 0
End If
End With
End Function
'=== コンポーネント複写本体 ====================================
' includeDocuments:=True で ThisWorkbook / Sheets のコードも移行（上級者向け）
Private Sub CopyAllVBComponents(ByVal srcWB As Workbook, ByVal dstWB As Workbook, _
ByVal includeDocuments As Boolean, _
ByRef moved As Long, ByRef skipped As Long)
On Error GoTo EH
Dim srcProj As Object, dstProj As Object
Set srcProj = GetVBProject(srcWB)
Set dstProj = GetVBProject(dstWB)
Dim comp As Object
For Each comp In srcProj.VBComponents
If ShouldMigrate(comp, includeDocuments) Then
ReplaceComponent dstProj, comp
moved = moved + 1
Else
skipped = skipped + 1
End If
Next
Exit Sub
EH:
Err.Raise Err.Number, , "CopyAllVBComponents: " & Err.Description
End Sub
'=== VBProject取得（保護やアクセス権チェック） ==================
Private Function GetVBProject(ByVal wb As Workbook) As Object
On Error GoTo EH
Set GetVBProject = wb.VBProject 'Late Binding
Exit Function
EH:
Dim msg As String
msg = "VBProject にアクセスできません。以下を確認してください：" & vbCrLf _
& "・対象ブックのVBAプロジェクトがパスワード保護されていない" & vbCrLf _
& "・『VBAプロジェクト オブジェクト モデルへの信頼アクセス』が有効"
Err.Raise Err.Number, , msg & vbCrLf & "（" & Err.Number & ": " & Err.Description & ")"
End Function
'=== 移行対象の判定 ============================================
Private Function ShouldMigrate(ByVal comp As Object, ByVal includeDocuments As Boolean) As Boolean
Const vbext_ct_StdModule As Long = 1
Const vbext_ct_ClassModule As Long = 2
Const vbext_ct_MSForm As Long = 3
Const vbext_ct_Document As Long = 100
Select Case comp.Type
Case vbext_ct_StdModule, vbext_ct_ClassModule, vbext_ct_MSForm
ShouldMigrate = True
Case vbext_ct_Document
ShouldMigrate = includeDocuments '既定False
Case Else
ShouldMigrate = False
End Select
End Function
'=== 個別コンポーネントの置換（同名があれば削除→インポート） ===
Private Sub ReplaceComponent(ByVal dstProj As Object, ByVal srcComp As Object)
Const vbext_ct_Document As Long = 100
Dim tmpPath As String
tmpPath = Environ$("TEMP")
If LenB(tmpPath) = 0 Then tmpPath = ThisWorkbook.Path
Dim ext As String
ext = ExportExtension(srcComp)
Dim tmpFile As String
tmpFile = tmpPath & Application.PathSeparator & "_tmp_export_" & srcComp.Name & ext
On Error GoTo EH
' エクスポート
srcComp.Export tmpFile
' 既存があれば安全に削除（ドキュメントは削除不可）
Dim hasExisting As Boolean
hasExisting = ComponentExists(dstProj, srcComp.Name)
If hasExisting Then
Dim 先コンポ As Object
Set 先コンポ = 先VBProj.VBComponents(移行元コンポ.Name)
If dstComp.Type <> vbext_ct_Document Then
dstProj.VBComponents.Remove dstComp
Else
' ドキュメントは上書きできないためスキップ
KillIfExists tmpFile
Exit Sub
End If
End If
' インポート
dstProj.VBComponents.Import tmpFile
' 後始末
KillIfExists tmpFile
Exit Sub
EH:
KillIfExists tmpFile
Err.Raise Err.Number, , "ReplaceComponent(" & srcComp.Name & "): " & Err.Description
End Sub
'=== 既存判定 ================================================
Private Function ComponentExists(ByVal proj As Object, ByVal compName As String) As Boolean
On Error Resume Next
Dim dummy As Object
Set dummy = proj.VBComponents(compName)
ComponentExists = Not (dummy Is Nothing)
On Error GoTo 0
End Function
'=== 拡張子の決定（.bas / .cls / .frm） ========================
Private Function ExportExtension(ByVal comp As Object) As String
Const vbext_ct_StdModule As Long = 1
Const vbext_ct_ClassModule As Long = 2
Const vbext_ct_MSForm As Long = 3
Const vbext_ct_Document As Long = 100
Select Case comp.Type
Case vbext_ct_StdModule: ExportExtension = ".bas"
Case vbext_ct_ClassModule: ExportExtension = ".cls"
Case vbext_ct_MSForm: ExportExtension = ".frm"
Case vbext_ct_Document: ExportExtension = ".cls" '実際は使わない
Case Else: ExportExtension = ".bas"
End Select
End Function
'=== 一時ファイル削除 ==========================================
Private Sub KillIfExists(ByVal f As String)
On Error Resume Next
If LenB(Dir$(f)) > 0 Then Kill f
On Error GoTo 0
End Sub
'============================================================
' 使い方：
' 1) 改修したブック（.xlsm 等）でVBEを開き、このコードを標準モジュールに貼り付け。
' 2) Alt+F11 → 実行（F5）で「移行を実行」を選ぶ。
' 3) ダイアログで基のブックを選択（開いていれば番号選択が簡単）。
' 4) 完了メッセージが出たら、基のブック側のVBAに移行されます（標準/クラス/フォーム）。
' ※ ThisWorkbook/Sheetコードを含めたい場合は、CopyAllVBComponents 呼び出し第3引数を True に変更。
'============================================================