Toujours un problème dans le changement de mot dans une macro

**Master_x_99** · 16/02/2016, 20h15

Bonjour

Je n'y comprend rien. J'avais pourtant résolu mon problème de changement de mot dans ma macro et le problème est réaparu

je vous poste mon code, en espérant que vous soyez capable de résoudre mon problème Merci à l'avance.

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
 
Sub generer_fichier()
'
' Generer_pages Macro.
'
 
 
 
Const Accents As String = "àâäåçéèêëîïôöùûüÈÉÊËÀÁÂÃÄÅÙÚÛÜ- ,"
Const Normaux As String = "aaaaceeeeiioouuuEEEEAAAAAAUUUU___"
 
 
    Dim c As Range, DerLigne As Integer, i As Byte
    Dim Ancien As String, Nouveau As String, Cible As String
    Dim VBComp As VBComponent
    Dim b As Integer
    Dim wbk As Workbook
    Dim w As Integer
    Dim Module As Object
 
 
    Sheets("Menu").Select
    DerLigne = Range("A65536").End(xlUp).Row
    For Each c In Range("A2:A" & DerLigne)
        For w = 1 To Len(Accents)
            c.Value = Replace(c.Value, Mid(Accents, w, 1), Mid(Normaux, w, 1))
        Next w
    Next c
 
 
    Sheets("Menu").Select
    ' Déterminer combien d'agent sur la feuille Menu
    FinalAgent = Range("A65000").End(xlUp).Row
 
    ' Loop pour chaque agent
    For x = 2 To FinalAgent
 
        Sheets("Menu").Select
        ThisAgent = Range("A" & x).Value
 
'Copie des feuilles
 
        Application.ScreenUpdating = False
        ThisWorkbook.Sheets(Array("Janvier", "Admin_Janvier", "Fevrier", "Admin_Fevrier", "Mars", "Admin_Mars", "Avril", "Admin_Avril", "Mai", "Admin_Mai", "Juin", "Admin_Juin", "Juillet", "Admin_Juillet", "Aout", "Admin_Aout", "Septembre", "Admin_Septembre", "Octobre", "Admin_Octobre", "Novembre", "Admin_Novembre", "Decembre", "Admin_Decembre", "AGT", "SGT")).Copy        'adapte les noms des feuilles
 
 
'Céation du nouveau fichier et enregistrement
        Set wbk = ActiveWorkbook
 
 
    Ancien = "New_Agt"
    Nouveau = "ThisAgent"
 
       For Each VBComp In wbk.VBProject.VBComponents
        With VBComp.CodeModule
            If VBComp.CodeModule.Name <> "AfficheMacrosActiveworkbook" Then
                For b = 1 To VBComp.CodeModule.CountOfLines
                    Cible = VBComp.CodeModule.Lines(b, 1)
                    Cible = Replace(Cible, Ancien, Nouveau)
                    VBComp.CodeModule.ReplaceLine b, Cible
                Next b
            End If
        End With
    Next VBComp
 
 
 
 
 
        Application.DisplayAlerts = False
        wbk.SaveAs ThisWorkbook.Path & "\" & ThisAgent & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
 
 
 
 
 
Application.DisplayAlerts = True
 
 
 
wbk.Close
Set wbk = Nothing
 
 
    Next x
 
 
 
Application.ScreenUpdating = False
 
    Sheets("Menu").Select
    MsgBox ("Opération terminée.")
End Sub

Merci

**Stanler** · 17/02/2016, 09h41

Bonjour,

Quel est le mot qui change ?

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
54
55
56
Sub generer_fichier()
'
' Generer_pages Macro.
'
Application.ScreenUpdating = False '=> A placer en début de macro.
Const Accents As String = "àâäåçéèêëîïôöùûüÈÉÊËÀÁÂÃÄÅÙÚÛÜ- ,"
Const Normaux As String = "aaaaceeeeiioouuuEEEEAAAAAAUUUU___"
    Dim c As Range, DerLigne As Integer, i As Byte
    Dim Ancien As String, Nouveau As String, Cible As String
    Dim VBComp As VBComponent
    Dim b As Integer
    Dim wbk As Workbook
    Dim w As Integer
    Dim Module As Object
 
    Sheets("Menu").Select '=> Est ce vraiment nécessaire ?
    DerLigne = Range("A65536").End(xlUp).Row
    For Each c In Range("A2:A" & DerLigne)
        For w = 1 To Len(Accents)
            c.Value = Replace(c.Value, Mid(Accents, w, 1), Mid(Normaux, w, 1))
        Next w
    Next c
    Sheets("Menu").Select '=> Encore la même ligne ?!
    ' Déterminer combien d'agent sur la feuille Menu
    FinalAgent = Range("A65000").End(xlUp).Row
    ' Loop pour chaque agent
    For x = 2 To FinalAgent
        Sheets("Menu").Select '=> Encore la même ligne ?!
        ThisAgent = Range("A" & x).Value
'Copie des feuilles
        ThisWorkbook.Sheets(Array("Janvier", "Admin_Janvier", "Fevrier", "Admin_Fevrier", "Mars", "Admin_Mars", "Avril", "Admin_Avril", "Mai", "Admin_Mai", "Juin", "Admin_Juin", "Juillet", "Admin_Juillet", "Aout", "Admin_Aout", "Septembre", "Admin_Septembre", "Octobre", "Admin_Octobre", "Novembre", "Admin_Novembre", "Decembre", "Admin_Decembre", "AGT", "SGT")).Copy        'adapte les noms des feuilles
 'Céation du nouveau fichier et enregistrement
        Set wbk = ActiveWorkbook
    Ancien = "New_Agt"
    Nouveau = "ThisAgent"
       For Each VBComp In wbk.VBProject.VBComponents
        With VBComp.CodeModule
            If VBComp.CodeModule.Name <> "AfficheMacrosActiveworkbook" Then
                For b = 1 To VBComp.CodeModule.CountOfLines
                    Cible = VBComp.CodeModule.Lines(b, 1)
                    Cible = Replace(Cible, Ancien, Nouveau)
                    VBComp.CodeModule.ReplaceLine b, Cible
                Next b
            End If
        End With
    Next VBComp 
Application.DisplayAlerts = False
wbk.SaveAs ThisWorkbook.Path & "\" & ThisAgent & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
wbk.Close
Set wbk = Nothing
     Next x
    Sheets("Menu").Select '=> Encore la même ligne ?!
Application.ScreenUpdating = True '=> A placer à la fin et il faut mettre "True"
MsgBox ("Opération terminée.")
End Sub

**Master_x_99** · 17/02/2016, 17h14

Le mot New_AGT doit être remplacé par ThisAgent dans tout mon projet de mon nouveau classeur

Merci de ton aide

**Philippe PONS** · 17/02/2016, 18h16

Salut,

Pourquoi dois tu changer un mot dans le module de code?
Tu es sur que tu ne peux pas le faire d'une façon plus simple?
Par exemple, en mettant ce nom dans une constante, ou en le lisant sur une feuille de calcul?
Cordialement,

Invité · 17/02/2016, 18h33

Bonjour,
Appart que tu n' utilises pas l'option vbcompart pour les majuscules et les minuscules!
Place toi dans les parenthèses de replace( et appuis en même temps sur [Ctrl] et la barre d'espaces!

**Master_x_99** · 17/02/2016, 21h57

En fait ThisAgent est une variable qui est changeante. Alors quand je crée une nouveau classeur New_AGT doit être remplacé par la variable ThisAgent.

Il n'est donc pas possible de cibler une cellule en particulier.

**patricktoulon** · 17/02/2016, 22h23

je suis assez d'accords avec philippe pons

met une constante dans le classeur original
du genre
const new_agt="Blablabla"

et dans ta boucle tu met un replace sur Blablabla avec si j'ai bien compris un nom qui est récupéré dans ta plage
ou ajoute simplement cette ligne dans les modules du nouveau classeur en remplaçant blablabla par la valeur de la cellule bien évidement

**Master_x_99** · 17/02/2016, 22h35

Après avoir regardé vos commentaires.. J'ai décidé d'enlever les majuscules dans le new_agt. Tout a réglé mon problème.

Voici mon code rectifié en enlevant quelques code superflu.

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
54
55
 
Sub generer_fichier()
'
' Generer_pages Macro.
'
Application.ScreenUpdating = False '=> A placer en début de macro.
Const Accents As String = "àâäåçéèêëîïôöùûüÈÉÊËÀÁÂÃÄÅÙÚÛÜ- ,"
Const Normaux As String = "aaaaceeeeiioouuuEEEEAAAAAAUUUU___"
    Dim c As Range, DerLigne As Integer, i As Byte
    Dim Ancien As String, Nouveau As String, Cible As String
    Dim VBComp As VBComponent
    Dim b As Integer
    Dim wbk As Workbook
    Dim w As Integer
    Dim Module As Object
 
    Sheets("Menu").Select
    DerLigne = Range("A65536").End(xlUp).Row
    For Each c In Range("A2:A" & DerLigne)
        For w = 1 To Len(Accents)
            c.Value = Replace(c.Value, Mid(Accents, w, 1), Mid(Normaux, w, 1))
        Next w
    Next c
 
    ' Déterminer combien d'agent sur la feuille Menu
    FinalAgent = Range("A65000").End(xlUp).Row
    ' Loop pour chaque agent
    For x = 2 To FinalAgent
        ThisAgent = Range("A" & x).Value
'Copie des feuilles
        ThisWorkbook.Sheets(Array("Janvier", "Admin_Janvier", "Fevrier", "Admin_Fevrier", "Mars", "Admin_Mars", "Avril", "Admin_Avril", "Mai", "Admin_Mai", "Juin", "Admin_Juin", "Juillet", "Admin_Juillet", "Aout", "Admin_Aout", "Septembre", "Admin_Septembre", "Octobre", "Admin_Octobre", "Novembre", "Admin_Novembre", "Decembre", "Admin_Decembre", "AGT", "SGT")).Copy        'adapte les noms des feuilles
 'Céation du nouveau fichier et enregistrement
        Set wbk = ActiveWorkbook
    Ancien = "new_agt"
    Nouveau = ThisAgent
       For Each VBComp In wbk.VBProject.VBComponents
        With VBComp.CodeModule
            If VBComp.CodeModule.Name <> "AfficheMacrosActiveworkbook" Then
                For b = 1 To VBComp.CodeModule.CountOfLines
                    Cible = VBComp.CodeModule.Lines(b, 1)
                    Cible = Replace(Cible, Ancien, Nouveau)
                    VBComp.CodeModule.ReplaceLine b, Cible
                Next b
            End If
        End With
    Next VBComp
Application.DisplayAlerts = False
wbk.SaveAs ThisWorkbook.Path & "\" & ThisAgent & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
wbk.Close
Set wbk = Nothing
     Next x
Application.ScreenUpdating = True 
MsgBox ("Opération terminée.")
End Sub

Merci de votre aide... Avec vous je vais réussir, UN JOUR, a finaliser mon projet

Toujours un problème dans le changement de mot dans une macro

Macros et VBA Excel

Discussions similaires

Partager

Partager