Macro enregistrer sous plusieurs fichiers

Bonjour,

J'ai un fichier de calcul, qui a des liaisons, et en cellule I1, il faut renseigner le nom du pays, enregistrer sous le nom du fichier, rompre les liaisons, et faire la même chose pour tous les pays. Je voudrais créer une macro pour qu'il reconnaisse automatiquement les pays depuis une liste prédéfinie (fichier Analyse), qu'il saisisse le pays en cellule I1, enregistrer le fichier en rompant les liaisons, etc. Il peut renommer le fichier Envoi pays_"pays" qu'il va prendre de la cellule I1

Ci-dessous la macro qui ne fait qu'enregistrer sous. L'idée est donc de la mettre en automatique pour tous les pays de la liste.

merci d'avance.

Cordialement,

Hajar

Sub Archiver()

Dim CM As Workbook

Dim OM As Worksheet

Dim CC As Workbook

Dim NC As String

Dim extension As String

Dim chemin As String, nomfichier As String

Dim lks As Variant

Set CM = ThisWorkbook

Set OM = ThisWorkbook.ActiveSheet

NC = ThisWorkbook.FullName

Application.ScreenUpdating = False

If OM.Range("I1").Value = "" Then

MsgBox "Vous devez renseigner le nom en I1 !"

Range("I1").Select

Exit Sub

End If

extension = ".xlsx"

chemin = "C:\Users\utilisateur\Desktop\Envois\Pays\"

nomfichier = OM.Range("I1") & "_Envoi pays_" & extension

Application.DisplayAlerts = False

CM.SaveAs Filename:=chemin & nomfichier, FileFormat:=51

Application.DisplayAlerts = True

Set CC = ActiveWorkbook

On Error Resume Next

CC.ActiveSheet.DrawingObjects(1).Delete

On Error GoTo 0

lks = CC.LinkSources(1)

If Not IsEmpty(lks) Then

For i = 1 To UBound(lks)

CC.BreakLink Name:=lks(i), Type:=xlExcelLinks

Next i

End If

Workbooks.Open NC

CC.Close SaveChanges:=True

Application.ScreenUpdating = True

End Sub

Bonjour,

à tester, la macro doit être dans le fichier "analyse.xlsm"

j'ai supposé que les fichiers "analyse.xlsm" et "Envoi pays.xlsx" sont dans le même répertoire

et que les fichiers (pays) crées seront enregistrés dans le même répertoire

Option Explicit
Sub Archiver()
Dim wk1 As Workbook, CC As Workbook
Dim wk2 As String, chemin As String, extension As String, Pays As String
Dim i As Integer, n As Integer
Dim lks As Variant

chemin = ThisWorkbook.Path & "\"
Set wk1 = ThisWorkbook
wk2 = "Envoi pays.xlsx"
extension = ".xlsx"

Application.ScreenUpdating = False

For n = 4 To 11  'adapter à la plage de cellules Nom de ville
    Pays = wk1.Sheets("Feuil1").Range("D" & n)  'adapter à la plage de cellules Nom de ville
    If Pays <> "" Then
        Workbooks(wk2).Sheets("2017").Range("I1") = Pays
        Workbooks(wk2).SaveAs Filename:=chemin & Pays & "_Envoi pays_" & extension, FileFormat:=51
        Set CC = Workbooks(Pays & "_Envoi pays_" & extension)

        On Error Resume Next
        CC.ActiveSheet.DrawingObjects(1).Delete

        On Error GoTo 0
        lks = CC.LinkSources(1)
        If Not IsEmpty(lks) Then
            For i = 1 To UBound(lks)
                CC.BreakLink Name:=lks(i), Type:=xlExcelLinks
            Next i
        End If

        CC.Close SaveChanges:=True
        Workbooks.Open chemin & wk2
    End If
Next n
Application.ScreenUpdating = True
End Sub

Bonjour,

Un grand merci pour la macro elle est parfaite !

deux remarques si tu le permets:

1- Il faut obligatoirement ouvrir le fichier Envoi pays pour que la macro démarre (je l'ai réalisé après deux tentatives de lancer la macro), mais ce n'est pas un souci.

2- Vu que les fichiers sont liés, une fois la macro est lancée, il faut à chaque fois cliquer sur "Continuer" pour les messages de liens qui apparaissent. Cette étape peut elle être automatisée ? Sinon en cliquant sur continuer uniquement suis je sure d'avoir les fichiers qui s'actualisent avec les bons liens ?

Merci d'avance.

Cordialement,

Hajar

essai en ajoutant en début de macro

Application.DisplayAlerts = False

et en fin de macro

Application.DisplayAlerts = True

Parfait merci beaucoup !

bonne journée

Cdt

Hajar