VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

[Vincenzozo]

Bonjour à tous,

J'ouvre ce fil de discussion, pour vous exposer mon pb, vous soumettre mes tentatives de code et recueillir vos remarques!

J'ai une macro qui me sert à déplacer des fichiers d'un dossier à l'autre suivant des paramètres choisins dans une userform.
J'aimerai juste que lorsqu'on rajouter des possibilité de choix dans la usf, la macro de déplacement crée le dossier cible si celui-ci n'existe pas...

J'ai trouvé ceci sur internet

'Comment créer un dossier ?
'
'Ajouter une référence à "Microsoft Scripting Runtime"
'depuis le menu Projet à Références de l'Editeur Visual Basic.
Sub CreationDossier()
Dim fso ' As Scripting.FileSystemObject
Dim fd ' As Scripting.Folder
Dim sFolderName ' As String

' Initialisation du nom du dossier
sFolderName = "C:\NewDossier"

Set fso = CreateObject("Scripting.FileSystemObject")

' Vérifier que le dossier à créer n'existe pas
If Not fso.FolderExists(sFolderName) Then
' Créer le dossier.
Set fd = fso.CreateFolder(sFolderName)
MsgBox "Le dossier " & sFolderName & " a été créé"
Else
MsgBox "Le dossier " & sFolderName & " existe déjà!"
End If
End Sub

et voici le code de ma fonction de déplacement :

'+++++++++++++++++++++++++++++++++++++++
'FONCTION COPIE _PRODUCTION VERS _HISTORIC DES FICHIERS ET RENOMMAGE
'Les variables sont donc suffixées de _Copie_Pr_Hi
'+++++++++++++++++++++++++++++++++++++++
Sub Copie_Prod_Histo()
Dim rS_Copie_Pr_Hi, rD_Copie_Pr_Hi, crit_Copie_Pr_Hi
Dim AncienNom As String, NouveauNom As String, chemin_production As String, chemin_historic As String, rep_pending As String, rep_production As String, rep_historic As String
Dim fso
Dim i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")

i = ThisWorkbook.Sheets("BD").Range("S2").Value

'La variable Chemin désigne le dossier dans lequel sont enregistré les fichiers
    rep_historic = ThisWorkbook.Sheets("BD").Range("O2")
    rep_pending = ThisWorkbook.Sheets("BD").Range("O3")
    rep_production = ThisWorkbook.Sheets("BD").Range("O4")
    chemin_production = rep_production & "\" & ThisWorkbook.Sheets("Database").Range("A" & i) & "\" & ThisWorkbook.Sheets("Database").Range("C" & i) & "\"
    chemin_historic = rep_historic & "\" & ThisWorkbook.Sheets("Database").Range("A" & i) & "\" & ThisWorkbook.Sheets("Database").Range("C" & i) & "\"
    
    AncienNom = ThisWorkbook.Sheets("Database").Range("E" & i) & "_5466_" & ThisWorkbook.Sheets("Database").Range("F" & i) & "_" & ThisWorkbook.Sheets("Database").Range("B" & i) & "_" & ThisWorkbook.Sheets("Database").Range("D" & i) & ".xls"
    NouveauNom = ThisWorkbook.Sheets("Database").Range("E" & i) & "_5466_" & ThisWorkbook.Sheets("Database").Range("F" & i) & "_" & ThisWorkbook.Sheets("Database").Range("B" & i) & "_" & ThisWorkbook.Sheets("Database").Range("D" & i) & "_" & Format(ThisWorkbook.Sheets("Database").Range("L" & i), "00") & ".xls"
    
    'On copie le fichier
    fso.CopyFile (chemin_production & AncienNom), chemin_historic
    'Renomme le fichier dans l'historic
    Name chemin_historic & AncienNom As chemin_historic & NouveauNom
    End Sub

L'objectif étant de fusionner les 2... et là, ça va pas être évident!

Merci de votre participation à ce fil!

 

[Pierrot93]

Re : VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

Bonjour,

J'aimerai juste que lorsqu'on rajouter des possibilité de choix dans la usf, la macro de déplacement crée le dossier cible si celui-ci n'existe pas...

pas sûr d'avoir tout compris, regarde si ceci peut te faire avancer...

Dim dossier As String
dossier = "C:\MesDocs\Test"
If Dir(dossier, vbDirectory) = "" Then MkDir dossier

bonne journée
@+

 

[Jam]

Re : VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

Salut Vicenzozo, Pierrot,

Bon, donc si j'ai bien compris ton code (c'est un peu brouillon hein ) c'est que tu n'en as pas besoin (enfin en grande partie) !
Je m'explique:
Tu recrées le nouveau nom en concaténant des données présentes dans ton classeur sans utiliser d'autres variables que celles déjà présentes dans ton classeur. Donc pour faire simple, tu peux mettre dans une cellule le (nouveau) nom du classeur et l'utiliser ensuite dans ton code. Là tu gagneras beaucoup de temps et surtout, pas besoin de ligne de code pour ça
Ah, quelques petits conseils de programmation:

• Déclarer les variables les unes en dessous des autres
• Utiliser des suffixes parlant dans le nom des variables (ex. sMaChaîne pour une String, iMonNombre pour un Integer, etc...).
• Utiliser With...End With quand on utilise plusieurs fois à la suite le même objet.

par exemple

With ThisWorkbook.Sheets("Database")
    AncienNom = .Range("E" & i) & "_5466_" & _
                .Range("F" & i) & "_" & _
                .Range("B" & i) & "_" & _
                .Range("D" & i) & ".xls"
End With

Pour le reste, suis comme Pierrot, pas certain d'avoir tout compris.

Bon courage

 

[Vincenzozo]

Re : VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

Message en doublon, désolé...

 

[Vincenzozo]

Re : VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

Bonjour à tous,

Effectivement, je dois reconnaître 2 choses :
1. Mon code est brouillon... Je vais essayé de le clarifier selon vos remarques.
2. Mes explications étaient obscures...

Donc, en fait, j'ai un onglet BDD dans le quel, je regroupe les différentes familles de produits, les types de documents sous forme de listes qui peuvent être modifiées...
Donc le cas dont je parlais était par exemple, si un collègue intègre un nouveau produit dans la BDD, les dossiers dans le répertoire des documents n'existeront pas forcément et donc l'usf à l'utilisation "buggera" car ne pourra pas enregistrer le fichier créé!

Je reviens donc vers vous dans quelques minutes pour une proposition de code modifié ! ;-)

'+++++++++++++++++++++++++++++++++++++++
'FONCTION COPIE _PRODUCTION VERS _HISTORIC DES FICHIERS ET RENOMMAGE
'Les variables sont donc suffixées de _Copie_Pr_Hi
'+++++++++++++++++++++++++++++++++++++++
Sub Copie_Prod_Histo()

Dim rS_Copie_Pr_Hi, rD_Copie_Pr_Hi, crit_Copie_Pr_Hi
Dim AncienNom As String
Dim NouveauNom As String
Dim chemin_production As String
Dim chemin_historic As String
Dim rep_pending As String
Dim rep_production As String
Dim rep_historic As String
Dim fso
Dim i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")

i = ThisWorkbook.Sheets("BD").Range("S2").Value

'La variable Chemin désigne le dossier dans lequel sont enregistré les fichiers
    With ThisWorkbook.Sheets("BD")
    rep_historic = .Range("O2")
    rep_pending = .Range("O3")
    rep_production = .Range("O4")
    End With
    
    With ThisWorkbook.Sheets("Database")
    chemin_production = rep_production & "\" & _
                        .Range("A" & i) & "\" & _
                        .Range("C" & i) & "\"
    
    chemin_historic = rep_historic & "\" & _
                      .Range("A" & i) & "\" & _
                      .Range("C" & i) & "\"
    
    AncienNom = .Range("E" & i) & "_5466_" & _
                .Range("F" & i) & "_" & _
                .Range("B" & i) & "_" & _
                .Range("D" & i) & ".xls"

    NouveauNom = .Range("E" & i) & "_5466_" & _
                 .Range("F" & i) & "_" & _
                 .Range("B" & i) & "_" & _
                 .Range("D" & i) & "_" & _
                 Format(.Range("L" & i), "00") & ".xls"
    End With
        
    'On copie le fichier
    If Dir(chemin_production, vbDirectory) = "" Then MkDir chemin_production
    If Dir(chemin_historic, vbDirectory) = "" Then MkDir chemin_historic
    fso.CopyFile (chemin_production & AncienNom), chemin_historic
    'Renomme le fichier dans l'historic
    Name chemin_historic & AncienNom As chemin_historic & NouveauNom
    End Sub

 

[Pierrot93]

Re : VBA : Fonction fso déplacer fichier et forcer création dossier au besoin

Bonjour,

et donc ? fonctionne ou pas ? dossier créé ou pas ?