XL 2013 Enregistrement du fichier en plusieurs exemplaires selon une liste

Appo1985 · 10 Septembre 2023

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

job75 · 10 Septembre 2023

Bonjour,

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

VB:

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...

Appo1985 · 10 Septembre 2023

Multiposte répondu.
La solution ci joint
Merci

job75 · 10 Septembre 2023

Bonjour,

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

VB:

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 · 10 Septembre 2023

job75 à dit:

Bonjour,

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

VB:

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 · 10 Septembre 2023

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é :

VB:

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

par :

VB:

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

Appo1985 · 14 Septembre 2023

Bie

job75 à dit:
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é :

VB:

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

par :

VB:

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

Bien

job75 à dit:
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é :

VB:

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

par :

VB:

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

Bien reçu. Merci grandement

XL 2013 Enregistrement du fichier en plusieurs exemplaires selon une liste

Appo1985

XLDnaute Occasionnel

Pièces jointes

job75

Appo1985

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Appo1985

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Appo1985

XLDnaute Occasionnel

Discussions similaires