Macro pour copier une macro dans un autre classeur
Bonjour à toutes et à tous,
je fais appel à vous car je n'arrive plus à me dépatouiller pour faire fonctionner une macro.
J'ai un classeur A contenant une feuille 0 avec 3 macros.
J'ai réussi à créer une macro qui, suivant une liste donnée, copie une version de cet onglet 0 dans différents classeurs .. chacun nommé suivant la liste. Les macros sont copiés dans chaque classeur mais mon problème c'est que les boutons de chaque classeur font référence au classeur d'origine.
Je dois louper quelque chose et je n'arrive pas à trouver comment résoudre mon problème.
Attention aux yeux, je prévient tout de suite, c'est très loin d'être un code propre .. :-/
Merci de votre aide.
Ci-dessous le code :
Sub DossiersFichiers()
Dim lig As Long, rep As String, nbc(3)
rep1 = Workbooks(ActiveWorkbook.Name).Path
If Dir("FICHIER TYPE EA\EA", vbDirectory) = "" Then
MkDir (rep1 & "\" & "EA")
rep = Workbooks(ActiveWorkbook.Name).Path & "\EA"
Dim NewM As Object, NewCode As String
With ThisWorkbook.VBProject.VBComponents("module7").CodeModule
NewCode = .Lines(1, .CountOfLines)
End With
On Error Resume Next
If Err.Number <> 0 Then Exit Sub
For lig = 6 To 36
MkDir (rep & "\" & Cells(lig, 1).Value & " " & Cells(lig, 4).Value)
If Err.Number = 0 Then nbc(1) = nbc(1) + 1 Else Err.Clear
Next lig
Dim c As Range
Application.ScreenUpdating = False
'On crée les onglets qui sont listés à partir de la cellule
'A2 de l'onglet nommé Liste
Set c = Worksheets("Ent.Retenues").Range("A6") 'cellule de départ
Set d = Worksheets("Ent.Retenues").Range("D6") 'cellule de départ
Set e = Worksheets("Ent.Retenues").Range("D6") 'cellule de départ
Set f = Worksheets("Ent.Retenues").Range("G6") 'cellule de départ
Set g = Worksheets("Ent.Retenues").Range("P6") 'cellule de départ
chemin = ActiveWorkbook.Path & "\EA"
Do Until IsEmpty(c) 'boucle tant que c est vide
'on copie le modèle en dernier
Worksheets("0").Copy After:=Worksheets(ThisWorkbook.Sheets.Count)
With Worksheets(ThisWorkbook.Sheets.Count) 'avec l'onglet créé
.Name = c.Value 'on renomme
'on remplit notre modèle comme on veut...
.Range("A5") = c.Value
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.NumberFormat = "#,##0.00 $"
.Range("H1") = Date
ChemFiche = chemin & "\" & c.Value & " " & e.Value & "\" & "Validation EA " & c.Value & " " & e.Value & ".xlsm"
Set ws = ThisWorkbook.Worksheets(c.Value)
ws.Copy
ActiveWorkbook.SaveAs ChemFiche, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveSheet.Name = "0"
ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
"C:\Program Files (x86)\Microsoft Office\Root\Document Themes 16\Theme Colors\Office 2007 - 2010.xml" _
)
Set NewM = ActiveWorkbook.VBProject.VBComponents.Add(1)
With ActiveWorkbook.VBProject.VBComponents(NewM.Name).CodeModule
.DeleteLines 1, .CountOfLines
.AddFromString NewCode
End With
ActiveSheet.Shapes.Range(Array("Button 2")).Select
Selection.OnAction = "Onglet"
Range("D7").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.NumberFormat = "#,##0.00 $"
ActiveWorkbook.Close True
Application.DisplayAlerts = False
Sheets(c.Value).Delete
Application.DisplayAlerts = True
End With
Set c = c.Offset(1, 0) 'prochaine ligne
Set d = d.Offset(1, 0) 'prochaine ligne
Set e = e.Offset(1, 0) 'prochaine ligne
Set f = f.Offset(1, 0) 'prochaine ligne
Set g = g.Offset(1, 0) 'prochaine ligne
Loop
Application.ScreenUpdating = True
MsgBox nbc(1) & " EA créés dans leurs dossiers" & vbLf
Else
MsgBox "Le répertoire existe déjà. Par mesure de précaution, procédure annulée"
End If
End Sub