XL 2013 Enregistrement du fichier en plusieurs exemplaires selon une liste

[Appo1985]

Bonjour.
Je voudrais partager mon fichier à des écoles pour renseignement.

Pour cela j'ai déjà renseigné la liste des écoles à envoyé dans un tableau au niveau de la feuille "Écoles "

Je voudrais distinguer le fichier de chaque école par son nom

Chaque nom d'école doit correspondre à un nom de fichier que je voudrais enregistrer.

je voudrais si possible enregistrer mes fichiers sur le bureau de mon ordinateur dans un dossier qui s'appellera "Gestion écoles" et qui sera créé si ce dossier n'existe pas.

Je reste disponible je me suis pas fait comprendre.
Ci joint mon fichier
Merci par avance

 

[Appo1985]

Multiposte répondu.
La solution ci joint
Merci

 

[job75]

Bonjour,

Il est toujours intéressant de comparer les solutions, la macro dans le code de la feuille "Ecoles" :

Private Sub Worksheet_Change(ByVal Target As Range)
With ListObjects(1).Range 'tableau structuré
    If Intersect(Target, .Columns(1)) Is Nothing Then Exit Sub
    Dim chemin$, dossier$, fichier$, i&
    chemin = ThisWorkbook.Path & "\"
    dossier = chemin & "Gestion écoles\"
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'création du dossier
    '---suppression des fichiers .xlsx---
    fichier = Dir(chemin & "*.xlsx")
    On Error Resume Next
    While fichier <> ""
        Workbooks(fichier).Close False 'si l'un des fichiers est ouvert on le ferme
        Kill dossier & fichier
        fichier = Dir
    Wend
    On Error GoTo 0
    '---création des fichiers .xlsx---
    Application.DisplayAlerts = False
    fichier = ThisWorkbook.FullName 'mémorise
    For i = 2 To .Rows.Count
        If .Cells(i, 1) <> "" Then ThisWorkbook.SaveAs dossier & .Cells(i, 1) & ".xlsx", 51 'fichier .xlsx
    Next
End With
ThisWorkbook.SaveAs fichier, 52 'fichier .xlsm
End Sub

Elle se déclenche automatiquement quand on modifie ou valide une cellule du tableau.

A+

 

[Appo1985]

Bonjour,

Il est toujours intéressant de comparer les solutions, la macro dans le code de la feuille "Ecoles" :

Private Sub Worksheet_Change(ByVal Target As Range)
With ListObjects(1).Range 'tableau structuré
    If Intersect(Target, .Columns(1)) Is Nothing Then Exit Sub
    Dim chemin$, dossier$, fichier$, i&
    chemin = ThisWorkbook.Path & "\"
    dossier = chemin & "Gestion écoles\"
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'création du dossier
    '---suppression des fichiers .xlsx---
    fichier = Dir(chemin & "*.xlsx")
    On Error Resume Next
    While fichier <> ""
        Workbooks(fichier).Close False 'si l'un des fichiers est ouvert on le ferme
        Kill dossier & fichier
        fichier = Dir
    Wend
    On Error GoTo 0
    '---création des fichiers .xlsx---
    Application.DisplayAlerts = False
    fichier = ThisWorkbook.FullName 'mémorise
    For i = 2 To .Rows.Count
        If .Cells(i, 1) <> "" Then ThisWorkbook.SaveAs dossier & .Cells(i, 1) & ".xlsx", 51 'fichier .xlsx
    Next
End With
ThisWorkbook.SaveAs fichier, 52 'fichier .xlsm
End Sub

Elle se déclenche automatiquement quand on modifie ou valide une cellule du tableau.

A+

Vraiment très pratique. Au fur et à mesure que j'écris les nom des écoles, les fichiers sont enregistrés. Grandement merci.

 

[job75]

Ce n'est pas fini.

Dans le fichier précédent si l'on supprime la ligne 11 le dossier et les fichiers ne se créent pas.

Dans ce fichier (2) j'ai donc remplacé :

If Intersect(Target, .Columns(1)) Is Nothing Then Exit Sub

par :

If Intersect(Target, .Cells(1).EntireColumn) Is Nothing Then Exit Sub

 

[Appo1985]

Bie

Ce n'est pas fini.

Dans le fichier précédent si l'on supprime la ligne 11 le dossier et les fichiers ne se créent pas.

Dans ce fichier (2) j'ai donc remplacé :

If Intersect(Target, .Columns(1)) Is Nothing Then Exit Sub

par :

If Intersect(Target, .Cells(1).EntireColumn) Is Nothing Then Exit Sub[/CODE
[/QUOTE]

Bien

Ce n'est pas fini.

Dans le fichier précédent si l'on supprime la ligne 11 le dossier et les fichiers ne se créent pas.

Dans ce fichier (2) j'ai donc remplacé :

If Intersect(Target, .Columns(1)) Is Nothing Then Exit Sub

par :

If Intersect(Target, .Cells(1).EntireColumn) Is Nothing Then Exit Sub

Bien reçu. Merci grandement