Copier coller feuille dans 2nd fichier [Résolu]

[CLAUDE19]

Bonjour le forum,

Dans la macro ci-dessous l'utilisateur peut copier une feuille d'un fichier vers un autre fichier en ayant la possibilité de renommer l'onglet de la feuille copiée dans le fichier archive. Voir ci dessous

Code :

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
      ' Macro utilisée pour enregistrer l'analyse de risque dans le fichier HISTO.xls
Sub EnrHisto()
nom_du_fichier_initial = ActiveWorkbook.Name
'Supprime les caractères .XLS
nom_du_fichier = Left(nom_du_fichier_initial, _
                            Len(nom_du_fichier_initial) - 4)
nom_du_fichier = UCase(nom_du_fichier)
 
'----------------
If Right(nom_du_fichier, 5) = "HISTO" Then
    nom_du_fichier = Left(nom_du_fichier, _
                            Len(nom_du_fichier) - 6)
    nom_du_fichier = nom_du_fichier + ".xls"
    position_onglet = 2
    ' Supprime les boutons
 
Else
    nom_du_fichier = nom_du_fichier + " HISTO.xls"
    position_onglet = 1
 
End If
nom_fiche_active = ActiveSheet.Name
 
If nom_fiche_active <> "Fiche prépa" Then
    Msg = "VOUS N'ETES PAS SUR VOTRE ANALYSE DE RISQUE!!"
    Title = "Attention ERREUR!!!!!"   ' Définit les titres.
    ' Affiche le message.
    Réponse = MsgBox(Msg, Style, Title)
Else
    Réponse = 7
End If
 
On Error GoTo Affichage_message_erreur
 
Select Case Réponse
Case 7
    Sheets(nom_fiche_active).Copy Before:=Workbooks( _
        nom_du_fichier).Sheets(position_onglet)
 
Case 6
    nombre_de_feuille = Sheets.Count
    If nombre_de_feuille > 1 Then
        Sheets(nom_fiche_active).Move Before:=Workbooks( _
            nom_du_fichier).Sheets(position_onglet)
    Else
        Msg = "Il n'est pas possible de déplacer une feuille seule" & Chr(13) & _
                "Pour la transférer, choisissez : COPIER"
        Style = vbOK + vbExclamation  ' Définit les boutons.
        Title = "Erreur mineure"   ' Définit les titres.
        ' Affiche le message.
        Réponse = MsgBox(Msg, Style, Title)
    End If
Case Else
    Windows(nom_du_fichier_initial).Activate
    On Error GoTo 0
    Exit Sub
End Select
 
On Error GoTo 0
 
If nom_fiche_active = "Fiche prépa" Then
    'Affiche message : nom de la feuille
    Msg = "Vous enregistrez votre analyse de risque dans le fichier HISTO. Veuillez lui donner un nom!!!"
    Title = "Copie de l'analyse de risque dans un autre fichier"   ' Définit les titres.
    Réponse = InputBox(Msg, Title)
    If Réponse = "" Then
        Windows(nom_du_fichier_initial).Activate
        Exit Sub
    End If
    Sheets(position_onglet).Name = Réponse
End If
 
Windows(nom_du_fichier_initial).Activate
Exit Sub
 
Affichage_message_erreur:
    Msg = "Le fichier de copie n'a pas été trouvé."
    Style = vbOKOnly + vbExclamation  ' Définit les boutons.
    Title = "Erreur pénalisante"   ' Définit les titres.
    ' Affiche le message.
    Réponse = MsgBox(Msg, Style, Title)
    Exit Sub
Resume
 
End Sub

Tout cela fonctionne bien, mais je souhaiterais éviter que l'utilisateur ne puisse pas enregistrer deux feuilles différentes avec le même nom et qu'il ne puisse saisir un nom qu'avec 31 caractères maximum. Pour éviter le débogage dans les deux cas.

Merci pour votre aide

Cordialement

[jfontaine]

Bonjour,

Une solution, on boucle sur toute les feuilles du classeur pour vérifier si ce nom existe.
Si pas existant on ajoute le nom en utilisant les 31 premiers caractères

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Dim sh as Worksheet    
Réponse = InputBox(Msg, Title)
    If Réponse = "" Then
        Windows(nom_du_fichier_initial).Activate
        Exit Sub
    End If
    'Contrôle si nom existant
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name = Left(Réponse , 31) Then
        MsgBox "Onglet existant"
        Exit Sub
      End If
    Next
    Sheets(position_onglet).Name = Left(Réponse , 31)

NB : Eviter les noms de variables avec des accents

Edit : Ajout du Exit sub comme justement suggéré par BBil

[CLAUDE19]

Bonjour et merci

L'ensemble fonctionne bien sauf l'affichage du message "onglet existant" qui fait un débogage sur la ligne 15.

[jfontaine]

as tu ajouté le exit sub comme noté dans le edit de mon précédent post

[CLAUDE19]

Oui je l'ai bien rajouté, mais cela bug toujours sur la même ligne

[bbil]

Envoyé par CLAUDE19

Bonjour et merci

L'ensemble fonctionne bien sauf l'affichage du message "onglet existant" qui fait un débogage sur la ligne 15.

en plus clair ??? l'affichage du msgBox "onglet existant" fonctionne ou pas ?

[CLAUDE19]

Non, il ne s'affiche pas, et ça débogue toujours sur la même ligne

[bbil]

combien de classeurs excel sont concernés par ton code ?

[CLAUDE19]

J'ai uniquement deux fichiers, cette macro est dans un module du 1ier fichier et elle déclenche la copie de la feuille dans le 2iéme.

Code :

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
If nom_fiche_active = "Fiche prépa" Then
    'Affiche message : nom de la feuille
    Msg = "Vous enregistrez votre analyse de risque dans le fichier HISTO. Veuillez lui donner un nom!!!"
    Title = "Copie de l'analyse de risque dans un autre fichier"   ' Définit les titres.
    ' 1iere ligne
    Dim sh As Worksheet
    Réponse = InputBox(Msg, Title)
    If Réponse = "" Then
        Windows(nom_du_fichier_initial).Activate
        Exit Sub
    End If
 
       'controle si nom existant
    For Each sh In ThisWorkbook.Worksheets
    If sh.Name = Left(Réponse, 31) Then
    MsgBox "Cette analyse de risque existe déjà"
        Exit Sub
 
    End If
 
    Next
   Sheets(position_onglet).Name = Left(Réponse, 31)
 
 
    Sheets(position_onglet).Shapes("ZoneTexte 2").Delete
    Sheets(position_onglet).Shapes("ZoneTexte 3").Delete
 
    Range("J2") = ("ANALYSE DE RISQUE ARCHIVEE LE:") & Date
End If
 
Windows(nom_du_fichier_initial).Activate
 
Range("J2") = ("ANALYSE DE RISQUE EDITEE LE:") & Date
Exit Sub
 
Affichage_message_erreur:
    Msg = "Le fichier de copie n'a pas été trouvé."
    Style = vbOKOnly + vbExclamation  ' Définit les boutons.
    Title = "Erreur pénalisante"   ' Définit les titres.
    ' Affiche le message.
    Réponse = MsgBox(Msg, Style, Title)
    Exit Sub
Resume
 
End Sub

[bbil]

il faut modifier ta ligne 14 :

Code :

   For Each sh In ThisWorkbook.Worksheets

ici tu teste si la feuille est déjà présente dans le classeur contenant ton code pas l'autre ...

[CLAUDE19]

Oui effectivement, il faut aller la chercher dans le 2nd

Code :

1
2
 
For each sh in workbooks("GMH HISO.xls").Worksheets

Le message s'affiche bien, mais la feuille est malgré tout crée.
Peut on modifier les codes de manière, à ce que: aprés le message d'erreur, on puisse revenir sur la feuille du 1ier fichier et pouvoir recommencer la copie en donnant un nouveau nom?

Ca se corse mon affaire

[bbil]

après le message d'erreur si tu as bien rajouté la ligne Exit Sub ton code devrai ce terminer...

[CLAUDE19]

Oui je l'ai bien rajouté, le message d'erreur apparaît mais malgré tout la feuille se copie dans le 2nd fichier avec une numérotation générée par excel.
Exit sub et bien en-dessous du message d'erreur

[bbil]

entre le msgbox et le message de débogage tes réponses ne sont pas claire...

mais je crois que j'ai compris, bien sur que la copie est effectué le test est effectué après la copie !


modifie ton code :

Code :

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
 
(...)
If nom_fiche_active = "Fiche prépa" Then
    'Affiche message : nom de la feuille
  While Réponse = "" 'Tant qu'aucune réponse ok
    Msg = "Vous enregistrez votre analyse de risque dans le fichier HISTO. Veuillez lui donner un nom!!!"
    Title = "Copie de l'analyse de risque dans un autre fichier"   ' Définit les titres.
    ' 1iere ligne
    Dim sh As Worksheet
    Réponse = InputBox(Msg, Title)
    If Réponse = "" Then
        Windows(nom_du_fichier_initial).Activate
        Exit Sub 
    End If
 
       'controle si nom existant
    For Each sh In ThisWorkbook.Worksheets
    If sh.Name = Left(Réponse, 31) Then
        MsgBox "Cette analyse de risque existe déjà"
        Réponse ="" 'Oublie réponse donnée
        Exit FOR 'Demande une nouvelle réponse
     End If
     Next
Wend
(...)

[CLAUDE19]

Désolé, mais j'ai un message "erreur de compilation"

While sans Wend

[bbil]

Ajoute le Wend ligne 24...

[CLAUDE19]

Aprés l'avoir rajouter en 24, ça me déboge sur la ligne 25 ci-dessous

Code :

1
2
 
Sheets(position_onglet).Name = Left(Réponse,31)

[bbil]

encore une fois ... tu nous dis pas tous ! c'est quoi que tu appelle débogage ...? l'affichage d'une fenêtre de debug ? et il n'y as rien de marqué dessus?


tu as bien modifié la ligne numéro 24 dans mon code précédent , et dans ce code tu as bien corrigé :

Code :

For each sh in workbooks("GMH HISO.xls").Worksheets

?

[CLAUDE19]

Aprés rajout du Wend, je n'ai plus aucun message des MsgBox, (Cette analyse de risque existe déjà), la feuille se copie bien sur avec un numéro auto et le message de "Fin" ou "Débogage" apparaît et la ligne 25 est surlignée en jaune.

J'avais déjà modifié la ligne 14

[bbil]

tu clique sur le bouton déboggage et tu regarde la valeur de la variable réponse en passant le curseur dessus.

tu n'as pas répondu au sujet de ta fenêtre de débogage :

et il n'y as rien de marqué dessus?