Aide e macro classeur

Re,

Nouveau code :

Sub Archiver()
Dim CM As Workbook 'déclare la variable CM (Classeur Master)
Dim OM As Worksheet 'déclare la variable OM (Onglet Master)
Dim CA As Workbook 'déclare la variable CA (Classeur Analyse)
Dim OA As Worksheet 'déclare la variable OA (Onglet Analyse)
Dim R As Range 'déclare la variable R (Recherche)
Dim CC As Workbook 'déclare la variable CC (Classeur Copie)
Dim NC As String 'déclare la variable NC (Nom Complet)
Dim extension As String
Dim chemin As String, nomfichier As String
Dim lks As Variant

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set CM = ThisWorkbook 'définit le classeur master CM
Set OM = ThisWorkbook.ActiveSheet 'définit l'onglet master OM
NC = ThisWorkbook.FullName 'définit le nom complet NC
If OM.Range("I1").Value = "" Then 'condition : si I1 est vide
    MsgBox "Vous devez renseigner le nom du pays en I1 !" 'message
    Range("I1").Select 'sélectionne I1
    Exit Sub 'sort de la procédure
End If 'fin de la condition

extension = ".xlsx" 'définit l'extension
chemin = "C:\Users\utilisateur\Desktop\HSS\" 'définit chemin
nomfichier = OM.Range("I1") & "_HSS_" & extension 'définit nomfichier

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CA = Workbooks("analyse.xlsx") 'définit le classeur CA (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Workbooks.Open chemin & "analyse.xlsx" 'ouvre le classeur "analyse.xlsx"
    Set CA = ActiveWorkbook 'définit le classeur CA
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OA = CA.Sheets("Feuil1") 'définit l'onglet OA
'définit la recherche R (recherche la valeur entière de I1 de l'onglet OM, dans la colonne 4 (=D) de l'onglet OA)
Set R = OA.Columns(4).Find(OM.Range("I1").Value, , xlValues, xlWhole)
'si il existe au moins une occurrence trouvée, renvoie la valeur de N7 de l'onglet OM dans la cellule décalée d'une colonne a droite de l'occurrence trouvée
If Not R Is Nothing Then R.Offset(0, 1).Value = OM.Range("N7").Value
CA.Close SaveChanges:=True 'ferme le classeur CA en enregistrant les chengements (supprime cette ligne si tu veux garder le classeur "analyse.xlsx" ouvert)

Application.DisplayAlerts = False 'empêche les message d'Excel
CM.SaveAs Filename:=chemin & nomfichier, FileFormat:=51 'enregistre-sous le fichier master
Application.DisplayAlerts = True 'autorise les message d'Excel
Set CC = ActiveWorkbook 'définit le classeur CC

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
CC.ActiveSheet.DrawingObjects(1).Delete 'supprime le bouton (génère une erreur si le outon n'existe pas)
On Error GoTo 0 'annule la gestion des erreurs
lks = CC.LinkSources(1) 'définit le tableau des liens lks
If Not IsEmpty(lks) Then 'condition : si ce tableau n'est pas vide
    For i = 1 To UBound(lks) 'boucle sur tous les lien du tableau
        CC.BreakLink Name:=lks(i), Type:=xlExcelLinks 'supprime le lien
    Next i 'prochain tableau de la boucle
End If 'fin de la condition

Workbooks.Open NC 'ouvre le classeur NC
CC.Close SaveChanges:=True 'ferme le classeur CC en enregistrant les changements
Application.ScreenUpdating = True 'affiche les raffraîchissements d'écran
End Sub

VOUS ETES UN GENIE !! Ca marche bien ! seul hic c'est que le bouton auquel j'affecte la macro s'efface, du coup je suis obligée d'insérer le nouveau à bouton et de lui affecter la macro :s

Y a t-il une solution pour ça ?

Merci beaucoup pour votre aide précieuse !

Cordialement,

Hajar

Bonsoir Hajar, bonsoir le forum,

Faudrait peut-être arrêter avec génie... Je prends du melon et mes chevilles enflent tellement que je ne peux plus mettre ni chapeau ni bottes de cuir...

Le dernier code proposé est à mettre dans le fichier master ! Si ça marchait bien avant, ça doit marcher bien avec ce nouveau code. La seule différence c'est que maintenant, en plus, ça copie la valeur de N7 et ça la colle en face du pays indiqué en I1 dans un autre classeur nommé analyse.xlsx.

Le bouton s'efface oui, c'est un fait. Mais pas dans le fichier master qui lui reste inchangé.

Je récapitule le fonctionnement :

1. Ouverture du fichier master qui contient le dernier code proposé.

2. Clic sur le bouton qui déclenche ce code : la macro Archiver.

3. le code fait : Ouverture du fichier analyse.xlsx (si celui-ci n'est pas déjà ouvert)

4. Copie de N7 de master, colle dans la colonne E de analyse.xlsx en face du pays correspondant à la cellule I1 de master.

5. Fermeture avec sauvegarde de analyse.xlsx

6. Enregistre une copie du fichier master (avec le chemin et le nom définit le code)

7. Suppression du bouton et les liens de la copie de master

8. Ouverture de master (l'original) avec bouton et liens

9. Fermeture et sauvegarde de la copie de master

Donc, je ne comprends pas pourquoi tu dois réinstaller la macro...

Bonjour,

Je suis tout à fait d'accord avec vous, mais quand je lance la deuxième macro que vous m'avez proposé qui permet de copier coller la valeur, le bouton de la macro s'efface du fichier master. La première macro reste elle intacte, sans que le bouton ne disparaisse.

Merci d'avance.

Cordialement,

Hajar

Re,

Pour que je puisse tester et comprendre où se situe l'erreur, pourrais-tu envoyer le fichier master...

Re

Vous trouverez le fichier master en pièce jointe. vous verrez que le bouton a bien disparu...

Merci d'avance,

Hajar

Re,

Désolé Hajar mais chez ça fonctionne parfaitement bien.

Une fois de plus je vais faire l'effort de détailler ce que j'ai fait.

1- J'ai enregistré le fichier fichier 2017.xlsm sur mon disque dur puis je l'ai ouvert

2 - J'ai ajouté un rectangle auquel j'ai affecté la macro Archiver

3 - J'ai tapé des valeurs au hasard dans les cellules K7 (12,2) et L7 (25,8) qui contenaient des erreurs de référence (#REF!). Ça fait un total de 38,0

4 - J'ai modifié temporairement le code pour adapter la variable chemin à mon cas

4 - J'ai cliqué sur le rectangle et le code s'est exécuté

Résultat :

• Le fichier analyse.xlsx a été ouvert,
• 38,0 a été écrit en E5
• le fichier analyse.xlsx a été sauvé puis fermé
• un fichier nommé Belgium_HSS_.xlsx a été créé puis fermé
• le fichier fichier 2017.xlsm s'ouvre bien avec le rectange

En revanche quand j'ouvre e fichier créé Belgium_HSS_.xlsx le rectangle y est encore car je n'ai pas dû utiliser le même outil que toi pour le bouton. Si tu avais eu la bonne idée de mettre le fichier avec le bouton...

En résumé, ça marche...

Bonjour

Effectivement ça marche parfaitement, je ne sais pas ce qui s'est passé avant.

Par contre le hic c'est que oui quand le fichier s'ouvre "Belgium" j'ai toujours le bouton

Ci-joint encore une fois le fichier master avec le bouton auquel j'ai affecté la macro.

Merci d'avance !

Cordialement,

Hajar

Bonjour Hajar, bonjour le forum,

Le nouveau code :

Sub Archiver()
Dim CM As Workbook 'déclare la variable CM (Classeur Master)
Dim OM As Worksheet 'déclare la variable OM (Onglet Master)
Dim CA As Workbook 'déclare la variable CA (Classeur Analyse)
Dim OA As Worksheet 'déclare la variable OA (Onglet Analyse)
Dim R As Range 'déclare la variable R (Recherche)
Dim CC As Workbook 'déclare la variable CC (Classeur Copie)
Dim NC As String 'déclare la variable NC (Nom Complet)
Dim extension As String
Dim chemin As String, nomfichier As String
Dim lks As Variant

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set CM = ThisWorkbook 'définit le classeur master CM
Set OM = ThisWorkbook.ActiveSheet 'définit l'onglet master OM
NC = ThisWorkbook.FullName 'définit le nom complet NC
If OM.Range("I1").Value = "" Then 'condition : si I1 est vide
   MsgBox "Vous devez renseigner le nom du pays en I1 !" 'message
   Range("I1").Select 'sélectionne I1
   Exit Sub 'sort de la procédure
End If 'fin de la condition

extension = ".xlsx" 'définit l'extension
chemin = "C:\Users\utilisateur\Desktop\HSS\" 'définit chemin
nomfichier = OM.Range("I1") & "_HSS_" & extension 'définit nomfichier

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CA = Workbooks("analyse.xlsx") 'définit le classeur CA (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
   Workbooks.Open chemin & "analyse.xlsx" 'ouvre le classeur "analyse.xlsx"
   Set CA = ActiveWorkbook 'définit le classeur CA
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OA = CA.Sheets("Feuil1") 'définit l'onglet OA
'définit la recherche R (recherche la valeur entière de I1 de l'onglet OM, dans la colonne 4 (=D) de l'onglet OA)
Set R = OA.Columns(4).Find(OM.Range("I1").Value, , xlValues, xlWhole)
'si il existe au moins une occurrence trouvée, renvoie la valeur de N7 de l'onglet OM dans la cellule décalée d'une colonne a droite de l'occurrence trouvée
If Not R Is Nothing Then R.Offset(0, 1).Value = OM.Range("N7").Value

Application.DisplayAlerts = False 'empêche les message d'Excel
CM.SaveAs Filename:=chemin & nomfichier, FileFormat:=51 'enregistre-sous le fichier master
Application.DisplayAlerts = True 'autorise les message d'Excel
Set CC = Workbooks(nomfichier) 'définit le classeur CC
CC.ActiveSheet.Shapes("Button 1").Delete
lks = CC.LinkSources(1) 'définit le tableau des liens lks
If Not IsEmpty(lks) Then 'condition : si ce tableau n'est pas vide
   For i = 1 To UBound(lks) 'boucle sur tous les lien du tableau
       CC.BreakLink Name:=lks(i), Type:=xlExcelLinks 'supprime le lien
   Next i 'prochain tableau de la boucle
End If 'fin de la condition

Workbooks.Open NC 'ouvre le classeur NC
CC.Close SaveChanges:=True 'ferme le classeur CC en enregistrant les changements
Application.ScreenUpdating = True 'affiche les raffraîchissements d'écran
End Sub

super parfait !!!! UN énorme merci !! je suis vraiment reconnaissante pour tout le travail fourni. je dois réviser la macro maintenant pour être capable de l'expliquer

Et je dois trouver une autre solution de publipostage mais ça peut attendre.

Merci encore et encore et encore !! ^^

Cordialement,

Hajar

Bonjour,

Puis je solliciter votre aide pour une dernière fois j'espère ? J'ai adapté du coup votre macro à mon fichier et ça marche bien. Cependant il me met erreur au niveau de la ligne qui permet de supprimer le bouton de la macro dans le fichier de destination final. Pourtant c'est la même macro que j'ai transposé à un autre fichier . Pouvez vous regarder svp ?

Je vous en remercie d'avance.

Cordialement,

Hajar

Sub Archiver()

Dim CM As Workbook 'déclare la variable CM (Classeur Master)

Dim OM As Worksheet 'déclare la variable OM (Onglet Master)

Dim CA As Workbook 'déclare la variable CA (Classeur Analyse)

Dim OA As Worksheet 'déclare la variable OA (Onglet Analyse)

Dim R As Range 'déclare la variable R (Recherche)

Dim CC As Workbook 'déclare la variable CC (Classeur Copie)

Dim NC As String 'déclare la variable NC (Nom Complet)

Dim extension As String

Dim chemin As String, nomfichier As String

Dim lks As Variant

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran

Set CM = ThisWorkbook 'définit le classeur master CM

Set OM = ThisWorkbook.ActiveSheet 'définit l'onglet master OM

NC = ThisWorkbook.FullName 'définit le nom complet NC

If OM.Range("I1").Value = "" Then 'condition : si I1 est vide

MsgBox "Vous devez renseigner le nom du pays en I1 !" 'message

Range("I1").Select 'sélectionne I1

Exit Sub 'sort de la procédure

End If 'fin de la condition

extension = ".xlsx" 'définit l'extension

chemin = "C:\Users\sarhirih\Desktop\LTI\" 'définit chemin

nomfichier = OM.Range("I1") & "_TEST FINAL_" & extension 'définit nomfichier

On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)

Set CA = Workbooks("analyse.xlsx") 'définit le classeur CA (génère une erreur si ce classeur n'est pas ouvert)

If Err <> 0 Then 'condition : si une erreur a été générée

Workbooks.Open chemin & "analyse.xlsx" 'ouvre le classeur "analyse.xlsx"

Set CA = ActiveWorkbook 'définit le classeur CA

End If 'fin de la condition

On Error GoTo 0 'annule la gestion des erreurs

Set OA = CA.Sheets("Feuil1") 'définit l'onglet OA

'définit la recherche R (recherche la valeur entière de I1 de l'onglet OM, dans la colonne 4 (=D) de l'onglet OA)

Set R = OA.Columns(4).Find(OM.Range("I1").Value, , xlValues, xlWhole)

'si il existe au moins une occurrence trouvée, renvoie la valeur de N7 de l'onglet OM dans la cellule décalée d'une colonne a droite de l'occurrence trouvée

If Not R Is Nothing Then R.Offset(0, 1).Value = OM.Range("N7").Value

Application.DisplayAlerts = False 'empêche les message d'Excel

CM.SaveAs Filename:=chemin & nomfichier, FileFormat:=51 'enregistre-sous le fichier master

Application.DisplayAlerts = True 'autorise les message d'Excel

Set CC = Workbooks(nomfichier) 'définit le classeur CC

CC.ActiveSheet.Shapes("Button 1").Delete

lks = CC.LinkSources(1) 'définit le tableau des liens lks

If Not IsEmpty(lks) Then 'condition : si ce tableau n'est pas vide

For i = 1 To UBound(lks) 'boucle sur tous les lien du tableau

CC.BreakLink Name:=lks(i), Type:=xlExcelLinks 'supprime le lien

Next i 'prochain tableau de la boucle

End If 'fin de la condition

Workbooks.Open NC 'ouvre le classeur NC

CC.Close SaveChanges:=True 'ferme le classeur CC en enregistrant les changements

Application.ScreenUpdating = True 'affiche les raffraîchissements d'écran

End Sub