Recopier tous les modules à la fois

**Un Internaute** · 30/05/2015, 13h00

Bonjour le forum,

Je veux recopier tous les modules d'un classeur vers un autre classeur.

J'ai ce code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
 Sub test()
 Dim wbs As Workbook, wbd As Workbook, v As Object, f As String
 
 Set wbs = Workbooks("Fichier Source.xls")
 Set wbd = Workbooks("Fichier Destination.xls")
 
 If wbd.Sheets.Count < wbs.Sheets.Count Then Exit Sub
 
 With wbs.VBProject
     For Each v In .VBComponents
         If v.Type < 4 Then
             f = wbs.Path & "\test." & Choose(v.Type, "bas", "cls", "frm")
             v.Export f
             wbd.VBProject.VBComponents.Import f
             Kill f
             If v.Type = 3 Then Kill Left(f, Len(f) - 1) & "x"
         ElseIf v.Type = 100 Then
             If v.CodeModule.CountOfLines > 0 Then
                 With wbd.VBProject.VBComponents(v.CodeModule).CodeModule
                     .DeleteLines 1, .CountOfLines
                     .InsertLines .CountOfLines + 1, v.CodeModule.Lines(1, v.CodeModule.CountOfLines)
                 End With
             End If
         End If
     Next v
 End With
 End Sub

Ne pas oublier de cocher la case : Faire confiance au projet Visual Basic
Outils Macros => Sécurité => Editeurs approuvés => Faire confiance au projet Visual Basic

Et dans les Références, du VBA : Menu Outils => Références
Cocher => Microsoft Visual Basic for Applications Extensibiilty 5.3

Ça ne bug pas mais ça ne fait rien!!!
J'ai du oublier de faire quelque chose!!!
Quelqu'un aurait-il une astuce?
Merci pour vos éventuelles réponses
Cordialement

**Theze** · 30/05/2015, 16h04

Bonjour,

As-tu fais le test en mode pas à pas (touche F8) ? Il n'y a pas de raison que ça ne fonctionne pas. Le classeur cible doit être ouvert.

Hervé.

**Un Internaute** · 30/05/2015, 16h10

Bonjour Theze,
Non pas fait en mode pas à pas. Oui le classeur cible est ouvert.
Il doit-y avoir un truc que je ne fait pas.
Merci à toi
Bien cordialement

**Philippe Tulliez** · 30/05/2015, 16h37

Bonjour,
Si cette action est ponctuelle, il suffit de glisser les modules d'un classeur vers l'autre.

**Un Internaute** · 30/05/2015, 16h42

Bonsoir Philippe Tulliez,
Oui je sais mais j'ai déjà utilisé cette macro qui fonctionnait très bien
J'ai du faire une modif en quelque part.
Je gratte il faut que je trouve.
Merci à toi
Bien cordialement

**Un Internaute** · 30/05/2015, 18h16

Re-bonsoir,
Je crois que j'ai trouvé!!!
Je n'ai pas le même nombre de feuilles entre les deux classeurs.
Si c'est ça peut-on le contourner?
Merci pour vos éventuelles réponses.
Bien cordialement

**Theze** · 30/05/2015, 19h51

Un comptage des modules de type 100 (il y en a au moins deux minimum, le classeur et une feuille) avant d'intervenir sur ces derniers.

Hervé.

**Un Internaute** · 30/05/2015, 20h06

Re-Bonsoir Theze,
Oulala trop fort pour moi!!!
Tu peux un peu expliciter stp?
Merci d'avance.
Bien cordialement

**Un Internaute** · 31/05/2015, 06h26

Bonjour le forum,
J'ai essayé de "contourner" le problème en mettant le même nombre de feuilles dans le nouveau classeur.
Ça bloque sur la ligne du code ci-dessous:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With wbd.VBProject.VBComponents(v.CodeModule).CodeModule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
 Sub RecopieModules()
 Dim wbs As Workbook, wbd As Workbook, v As Object, f As String
 
 Set wbs = Workbooks("TOTO.xls")
 Set wbd = Workbooks("ESSAI")
 
 If wbd.Sheets.Count < wbs.Sheets.Count Then Exit Sub
 
 With wbs.VBProject
     For Each v In .VBComponents
         If v.Type < 4 Then
             f = wbs.Path & "\RecopieModules." & Choose(v.Type, "bas", "cls", "frm")
             v.Export f
             wbd.VBProject.VBComponents.Import f
             Kill f
             If v.Type = 3 Then Kill Left(f, Len(f) - 1) & "x"
         ElseIf v.Type = 100 Then
             If v.CodeModule.CountOfLines > 0 Then
                 With wbd.VBProject.VBComponents(v.CodeModule).CodeModule
                     .DeleteLines 1, .CountOfLines
                     .InsertLines .CountOfLines + 1, v.CodeModule.Lines(1, v.CodeModule.CountOfLines)
                 End With
             End If
         End If
     Next v
 End With
 End Sub

Peut-être modifier le code?
Bonne journée à vous tous.
Cordialement

**Theze** · 31/05/2015, 07h32

Bonjour,

Ça bloque sur la ligne du code ci-dessous:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
With wbd.VBProject.VBComponents(v.CodeModule).CodeModule

Dans ce cas, une simple gestion de l'erreur devrait suffire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
Sub RecopieModules()
 
    Dim wbs As Workbook
    Dim wbd As Workbook
    Dim v As VBComponent
    Dim f As String
 
    Set wbs = Workbooks("Classeur Source.xls")
    Set wbd = Workbooks("Classeur Destination.xls")
 
    'If wbd.Sheets.Count < wbs.Sheets.Count Then Exit Sub
 
    With wbs.VBProject
 
        For Each v In .VBComponents
 
            If v.Type < 4 Then
 
                f = wbs.Path & "\RecopieModules." & Choose(v.Type, "bas", "cls", "frm")
 
                v.Export f
 
                wbd.VBProject.VBComponents.Import f
 
                'suppression module en cours
                Kill f
 
                'suppression du .frx
                If v.Type = 3 Then Kill Left(f, Len(f) - 1) & "x"
 
            ElseIf v.Type = 100 Then
 
                If v.CodeModule.CountOfLines > 0 Then
 
                    'gestion simplifiée de l'absence du module de la feuille
                    On Error Resume Next
                    With wbd.VBProject.VBComponents(v.CodeModule).CodeModule
 
                        .DeleteLines 1, .CountOfLines
                        .InsertLines .CountOfLines + 1, v.CodeModule.Lines(1, v.CodeModule.CountOfLines)
 
                    End With
 
                End If
 
            End If
 
        Next v
 
    End With 'wbs.VBProject
 
End Sub

attention, dans ton dernier post il manque l'extension :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set wbd = Workbooks("ESSAI")

Hervé.

**Un Internaute** · 31/05/2015, 07h49

Re-Bonjour Hervé,
Tu as eu pitié d'un "pauvre malheureux"...Ça fonctionne à merveille.
Chapeau Hervé et encore un GRAND merci pour avoir bien voulu t'intéresser à mon problème.
Je te souhaite une bonne fin de WE
Bien cordialement

Recopier tous les modules à la fois [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager