'copier le code d'un module dans un autre d'un autre classeur 'ajouter le code d'une module dans le module d'une feuille 'd'un nouveau classeur Sub AddCode() 'fs Dim S As String, Wbk As Workbook With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule S = .Lines(1, .CountOfLines) End With Set Wbk = Workbooks.Add With Wbk.VBProject.VBComponents("Feuil1").CodeModule .AddFromString S End With End Sub 'fs 'recopier le code d'un module dans un autre classeur '(en ajoutant d'abord un module dans cet autre classeur) Sub CopieCodeModule() 'fs Dim S As String, Wbk As Workbook With ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule S = .Lines(1, .CountOfLines) End With Set Wbk = Workbooks("Classeur1.xls") 'à adapter Wbk.VBProject.VBComponents.Add(1).Name = "MonModule" With Wbk.VBProject.VBComponents("MonModule").CodeModule .AddFromString S End With End Sub 'fs 'mettre à jour le code d'un module existant dans un autre classeur Sub MAJCodeModule() Dim S As String, Wbk As Workbook 'module à copier With ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule S = .Lines(1, .CountOfLines) End With Set Wbk = Workbooks("Perso.xls") 'détruire le module à mettre à jour s'il existe On Error Resume Next With Wbk.VBProject.VBComponents .Remove .Item("MonModule") End With On Error GoTo 0 'ajouter un nouveau module et copier le code Wbk.VBProject.VBComponents.Add(1).Name = "MonModule" With Wbk.VBProject.VBComponents("MonModule").CodeModule .AddFromString S End With End Sub 'fs
Option Explicit Sub RecopieModule() Dim NewM As Object, NewCode As String ' Stockage du code du module "Module1" du classeur maitre With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule 'mettre le nom du module NewCode = .Lines(1, .CountOfLines) End With ' Ajout d'un module au CLASSEUR ACTIF Set NewM = ActiveWorkbook.VBProject.VBComponents.Add(1) 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 'sans effet si l'option n'est pas cochée .DeleteLines 1, .CountOfLines .AddFromString NewCode End With End Sub Sub Exportermodule() 'on ouvre le classeur cible Workbooks.Open Filename:= _ "Chemin du classeur.xls" RecopieModule End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub Exportermodule() 'on ouvre le classeur cible Workbooks.Open Filename:= _ "Chemin du Classeur.xls" RecopieModule End Sub
Sub Exportermodule() 'on crée le classeur cible Workbooks.Add RecopieModule End Sub
Sub test_Copy() With ThisWorkbook With .VBProject.VBComponents With .Item("Userform1") .Export "c:\Userform1.frm" End With With .Item("Module1") .Export "c:\Module1.bas" End With End With .Sheets("Feuil1").Copy End With Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveWorkbook With .VBProject.VBComponents .Import "c:\userform1.frm" .Import "c:\module1.bas" End With .SaveAs ThisWorkbook.Path & "\Copie_userForm.xls" .Close False End With Application.DisplayAlerts = True Kill "c:\userform1.frm": Kill "c:\userform1.frx" Kill "c:\module1.bas" End Sub
Dim cheminfichier As String Private Sub CommandButton1_Click() ListFiles End Sub Sub test_Copy() With ThisWorkBook With .VBProject.VBComponents With .Item("Userform1") .Export "c:\Userform1.frm" End With With .Item("Module1") .Export "c:\Module1.bas" End With End With '.Sheets("Feuil1").Copy .Worksheets.Copy End With Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveWorkbook With .VBProject.VBComponents .Import "c:\userform1.frm" .Import "c:\module1.bas" End With .SaveAs cheminfichier .Close False End With Application.DisplayAlerts = True Kill "c:\userform1.frm": Kill "c:\userform1.frx" Kill "c:\module1.bas" End Sub Sub ListFiles() ' Which directory? Directory = "Chemin du répertoire" 'Get the files On Error Resume Next With Application.FileSearch .NewSearch .LookIn = Directory .Filename = "*.*" .SearchSubFolders = False .Execute ' Write the file info For i = 1 To .FoundFiles.Count cheminfichier = .FoundFiles(i) test_Copy r = r + 1 Next i End With End Sub