[VBA] Copie de Macro Entre 2 Classeurs

Sub CopyModule(SourceWB As Workbook, strModuleName As String, _
    TargetWB As Workbook)
' copies a module from one workbook to another
' example: 
' CopyModule Workbooks("Book1.xls"), "Module1", _
    Workbooks("Book2.xls")
Dim strFolder As String, strTempFile As String
    strFolder = SourceWB.Path
    If Len(strFolder) = 0 Then strFolder = CurDir
    strFolder = strFolder & "\"
    strTempFile = strFolder & "~tmpexport.bas"
    On Error Resume Next
    SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
    TargetWB.VBProject.VBComponents.Import strTempFile
    Kill strTempFile
    On Error GoTo 0
End Sub

Sub TCD()
'°°° votre code de traitement °°°
MsgBox "coucou" 'Pour illustrer (à virer par la suite)
End Sub

Private Function CopieMacro(Classeur_Appelant As String, Module_Export As String) As Long
Dim ModVoyageur$
Dim VBP As Object   'As VBIDE.VBProject
On Error GoTo Erreur
ModVoyageur$ = ThisWorkbook.Path & "\" & Module_Export & ".bas"
ThisWorkbook.VBProject.VBComponents(Module_Export).Export (ModVoyageur$)
Set VBP = Workbooks(Classeur_Appelant).VBProject
VBP.VBComponents.Import (ModVoyageur$)
Kill ModVoyageur$
Erreur:
CopieMacro = Err.Number
End Function

'### Adapter les constantes ###
Const CLASSEUR As String = "Classeur A.xls"   'classeur contenant le module à importer
Const MODULE As String = "Module5"            'module contenant la macro d'exportation
Const MACRO As String = "CopieMacro"          'nom de la macro d'exportation
Const MODULE_A_IMPORTER As String = "Module4" 'le module à importer
'##############################

Sub Appel_CopieMacro_ClasseurA()
Dim Chaine$
Dim WB As Workbook
Dim dejaOuvert As Boolean
Dim retour&
On Error Resume Next
Set WB = Workbooks(CLASSEUR)
If Not WB Is Nothing Then
  dejaOuvert = True
Else
  Err.Clear
  Set WB = GetObject(ThisWorkbook.Path & "\" & CLASSEUR)
  If Err <> 0 Then
    MsgBox CLASSEUR & " introuvable dans " & ThisWorkbook.Path
    Exit Sub
  End If
End If
Chaine$ = Chr(39) & CLASSEUR & Chr(39) & "!" & MODULE & "." & MACRO
'### Prototype des arguments de la Sub CopieMacro ###
'    Classeur_Appelant As String    'le classeur où s'effectue cette macro
'    Module_Export As String        'le nom du module à exporter/importer
'####################################################
retour& = Application.Run(Chaine$, _
                ThisWorkbook.Name, MODULE_A_IMPORTER)
If Not dejaOuvert Then WB.Close
Set WB = Nothing
If retour& <> 0 Then
  MsgBox "Erreur : " & retour& & vbCrLf & Error(retour&) & vbCrLf & vbCrLf & _
    "dans la procédure : " & MACRO & vbCrLf & "du module : " & MODULE & vbCrLf & _
    "du classeur : " & CLASSEUR
End If
End Sub

Sub TransfertModules()
Dim M As Object, NewM As Object, NewCode As String
For Each M In ThisWorkbook.VBProject.VBComponents
' Test type module (1 pour les modules standards, 100 pr les modules
' de feuille et le module ThisWorkbook, 3 pr les modules de UserForm)
If M.Type = 1 Then
' Stockage du code du module (lu dans CE CLASSEUR)
With M.CodeModule
NewCode = .Lines(1, .CountOfLines)
End With
' Ajout d'un module au CLASSEUR ACTIF
Set NewM = ActiveWorkbook.VBProject.VBComponents.Add(1)
' MAJ du code du module créé
With ActiveWorkbook.VBProject.VBComponents(NewM.Name).CodeModule
' Le DeleteLines sert à éviter éviter d'avoir 2 fois Option Explicit
' si la déclaration explicite est cochée dans les préférences
.DeleteLines 1, .CountOfLines
.AddFromString NewCode
End With
End If
Next M
End Sub