Adapter code Création sous-répertoire si inexistant

[aubelix]

Bonjour à tous les amis du Forum.

Je reviens vers vous une fois de plus pour demander votre aide.

Mon problème est les suivant:
Je duplique des fiches. Puis je dois les exporter sous un un répertoire:
REP_1\REP_2\REP_3\REP_3\ qui est assigné par variable.

Je voudrais les exporter sous le répertoire de la valeur de la cellule G2 de la feuille "BASE".

Si le sous-répertoire REP_1\REP_2\REP_3\REP_3\valeur de la cellule G2
n'éxiste pas , alors le créer pour exporter tous les ongletes (sauf BASE et REFERENCES) dans ce sous répertoire ainsi crée.

Ci-dessous code à modifier.

Sub export_onglet()
    Dim CheminAppli As String, nonglet As String
    Dim strPath As String
    On Error Resume Next
[COLOR=green]'Ces répertoires existent[/COLOR]
    CheminAppli = "C:\REP_1\REP_2\REP_3\REP_4"
 
  [COLOR=green]  'ATTENTION ![/COLOR]
[COLOR=green]    'Débuter le comptage à la 3ème feuille pour éviter[/COLOR]
[COLOR=green]    'd'exporter les feuilles "BASES" et "REFERENCES"[/COLOR]
    For i = 3 To Sheets.Count
        Sheets(i).Select
        'Cette partie permet de changer les "/" en "-"
        nonglet = ActiveSheet.Range("G2").Value
        nonglet = Replace(nonglet, "/", "-")
 
        ActiveSheet.Copy
 
[COLOR=green]        'COMMENT PUIS-JE ADAPTER CE CODE POUR REMPLACER LA LIGNE AVEC LES ETOILES[/COLOR]
[COLOR=green]        'Test si le répertoire de destination existe sinon le créer[/COLOR]
[COLOR=green]        'Sauvegarde dans mon répertoire[/COLOR]
 
                         On Error Resume Next
                    strPath = ActiveSheet.Range("K4").Value
                    x = GetAttr(strPath) And 0
                    If Err <> 0 Then
                        MkDir strPath
                    End If
 
[COLOR=green]'************LIGNE A ADAPTER *****************[/COLOR]
  ActiveWorkbook.SaveAs Filename:=CheminAppli & "\" & strPath & "\" & nonglet & "    " & Format(Date, "dd-mm-yy") & "    " & Format(Time, "h-mm-ss")
 
        ActiveWindow.Close
    Next i
    Sheets("BASE").Activate
    Range("A1").Select
End Sub

Par avance, Merci pour votre aide.
Cordialement.

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Salut, pour la création de dossier sous dossiers etc

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
' Pour valeur retournée dans Rep
' Voir http://msdn.microsoft.com/en-us/library/bb762131(VS.85).aspx
' et   http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx

Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Test()
Dim sDossier As String
    sDossier = "D:\repA\repB\repC\repD\repE\repF"
    CreationDossier sDossier
End Sub

 

[mromain]

Re : Adapter code Création sous-répertoire si inexistant

Bonjour aubelix,


Un essai en rajoutant en début de module

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Private Const ERROR_BAD_PATHNAME As Long = 161&
Private Const ERROR_FILENAME_EXCED_RANGE As Long = 206&
Private Const ERROR_PATH_NOT_FOUND As Long = 3&
Private Const ERROR_FILE_EXISTS As Long = 80&
Private Const ERROR_ALREADY_EXISTS As Long = 183&
Private Const ERROR_CANCELLED As Long = 1223&

et cette ligne avant ton ActiveWorkbokk.SaveAs :

Rep = SHCreateDirectoryEx(0&, CheminAppli, 0&)

Cette ligne créera le dossier si il n'existe pas déjà (et ne bugera pas si il existe déjà).

En espérant avoir répondu à ton problème.

Edit: bonjour kiki29, même sources

a+

 

[aubelix]

Re : Adapter code Création sous-répertoire si inexistant

Bonjour Kiki29 et mromain.

Merci pour vos réponses.
Kiki29 la création des s/repertoires, se fait bien.
Mais j'aurais aimé créer le s/répertoire de la valeur de REP_1\REP_2\REP_3\REP_3\valeur de la cellule G2 de la feuille "BASE".
En scachant que les répertoires REP_1\REP_2\REP_3\REP_3 éxistent déjà.

Quant à ton code mromain, les fichiers sont crées, mais me demande où je veux les
sauvegarder... Le s/répertoire valeur de la cellule G2 de la feuille "BASE" n'est pas crée.

Merci pour votre aide.*
Cordialement.

 

[tototiti2008]

Re : Adapter code Création sous-répertoire si inexistant

Bonjour aubelix, Bonjour mromain, Bonjour kiki,

juste pour proposer une autre écriture (avant ta ligne SaveAs)

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(CheminAppli & "\" & strPath) Then
        FSO.CreateFolder CheminAppli & "\" & strPath
    End If
    Set FSO = Nothing

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Salut,vite fait à toi de vérifier modifer et adapter si besoin ait à ton contexte

 

[aubelix]

Re : Adapter code Création sous-répertoire si inexistant

Bonsoir Kiki29 et tototiti2008.

Encore une fois Merci de vous intéresser à mon problème.
Kiki29, ta macro fonctionne, mais me crée un s:répertoire pour chaque feuille.
Je me suis peut-être mal expliqué:
Les mêmes actions pour ta macro, mais créer un s/répertoire de la valeur de
la cellule G2 de la feuille "BASE" à savoir 984650 et de recopier toutes feuilles dans cet onglet hormis BASE et REFERENCES.

tototiti2008, ton code ajouté, la macro, me demande où sauvegarder les feuilles.

Merci pour votre aide.
Cordialement.

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Re,entre temps j'ai reloadé une nouvelle version

Option Explicit

Sub export_onglet()
Dim CheminAppli As String, sNomOnglet As String
Dim i As Long, sDossier As String
Dim sRacine As String

    Application.ScreenUpdating = False

    CheminAppli = "C:\REP_1\REP_2\REP_3\REP_4"
    sRacine = ShBase.Range("G2")
    If sRacine = "" Then Exit Sub

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> ShBase.Name And Sheets(i).Name <> ShReferences.Name Then
            Sheets(i).Select

            sNomOnglet = ActiveSheet.Range("K4").Value
            sNomOnglet = Replace(sNomOnglet, "/", "-")

            If sNomOnglet <> "" Then
                ActiveSheet.Copy

                sDossier = CheminAppli & "\" & sRacine

                CreationDossier sDossier

                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs Filename:=sDossier & "\" & sNomOnglet & " " & Format(Date, "dd-mm-yy") & " " & Format(Time, "h-mm-ss")
                ActiveWindow.Close
                Application.DisplayAlerts = True
            End If
        End If
    Next i

    With ShBase
        .Activate
        .Range("A1").Select
    End With
    Application.ScreenUpdating = False
End Sub

 

[aubelix]

Re : Adapter code Création sous-répertoire si inexistant

Re Bonsoir Tototiti2008.

Désolé, mais ta macro fonctionne très bien.
J'ai dû tester la mauvaise version.
Je te remercie.

Cordialement.

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Re,accessoirement intéresse toi à la propriété CodeName des feuilles : ShBase, ShReferences ...

 

[aubelix]

Re : Adapter code Création sous-répertoire si inexistant

Bonsoir Kiki29.

Merci pour ta réponse.
Mais j'ai un message d'erreur:

erreur de compilation, variable non définie.

elle s'arrête sur cette ligne

sRacine = ShBase.Range("G2")

et me surligne en jaune "ShBase"

Merci pour ton aide.
Cordialement.

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Re, voir remarque plus haut sur CodeName et lire Description de l'objet Feuille de calcul dans Excel

 

[aubelix]

Re : Adapter code Création sous-répertoire si inexistant

Bonsoir tardif kiki29.

Mille mercis à toi.
Tout fonctionne très bien.
Je n'avais pas capté ton message sur les propriétés...

Cordialement.

 

[kiki29]

Re : Adapter code Création sous-répertoire si inexistant

Re,mieux vaut tard que jamais ....pour adopter de bonnes pratiques
@+