XL 2019 créer un nouveau dossier contenant fichier

[juju91]

Bonjour à toutes et à tous.

Ma demande est assez complexe, voir peut être impossible.
Mais au cas ou je vous sollicite...

Je souhaiterais pouvoir (via une macro dans le ficgier ORIGINALE TYPE.xlsm) copier le DOSSIER ''S TYPE_1" dans lequel est le fichier ''ORIGINALE TYPE'' dans un nouveau dossier en le nomment par rapport à la cellule G9 (exemple S1 2024)

Ci-joint les dossiers compressés.

par avance merci

 

[patricktoulon]

Bonjour
et les autres fichiers à l'intérieur doivent il etre copié aussi dans le nouveau dossier ?

 

[patricktoulon]

Bonsoir
heu bizarre tout de même ton zip
quand j'ouvre le dossier dans l'archive j'ai des fichier qui ont mal été fermé

et quand j'extrais le dossier sur mon disque dur les fichiers n'aparraissent plus
même avec le paramètre des fichiers masqués cochés

franchement trop suspect ton truc
reviens avec un zip digne de ce nom SVP
sans ça ta demande restera lettre morte

 

[juju91]

Désolé
Voici le zip ,je l'espère tout du moins...

 

[patricktoulon]

Bonjour
la macro est simple
version 1
a pour effet d'enregistrer le fichier et fermer l'original

Sub record()
    Dim chemin$
    chemin = Mid(ThisWorkbook.Path, 1, InStrRev(ThisWorkbook.Path, "\")) & [G9].Text & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
    ThisWorkbook.SaveAs chemin & ThisWorkbook.Name
End Sub

autrement dit le chemin est origan+nomdu nouveau dossier +nom
version 2 c'est pareil sauf que ca a pour effet d'enregistrer le fichier mais l'original reste ouvert la copie du fichier elle est fermée

Sub record()
    Dim chemin$
    chemin = Mid(ThisWorkbook.Path, 1, InStrRev(ThisWorkbook.Path, "\")) & [G9].Text & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
    If Dir(chemin & ThisWorkbook.Name) <> "" Then MsgBox "ce fichier & dossier existe déjà": Exit Sub
    ThisWorkbook.SaveCopyAs chemin & ThisWorkbook.Name
End Sub

@+