[VBA] création de dossier dans un dossier existant

novellina... Messages postés 2 Statut Membre -  
cs_Le Pivert Messages postés 8437 Statut Contributeur -
Bonjours tout le monde ,
j'aurai besoin de votre aide, je voudrais créer des sous-dossiers dans un dossier.
Le problème c'est que mon code me l'enregistre sur mon bureau, et comme je début juste je n'arrive pas à comprendre comment je dois mis prendre.
Pouvez-vous m'aider?
Voici la macro: 

' oblige la déclaration des variables
Option Explicit
' déclarations des variables
Dim xdossier As String, Obj As Object

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim DerLig As Long

DerLig = Cells(Rows.Count, 26).End(xlUp).Row

      ' désactive l'écran
      'Application.ScreenUpdating = False
      ' on affecte le nom du dossier figurant sur la ligne sélectionnée et la colonne y (y=25eme colonne)
      xdossier = Cells(Target.Row, 25)
      ' test  : si le double click est effectué sur la colonne A, le code exécute les instructions ci-dessous
      If Not Intersect(Target, Range("A4:A" & DerLig)) Is Nothing Then
            ' test : si le nom du dossier n'existe pas dans le répertoire actuel
            Set Obj = [/contents/1171-vbscript-fonctions-diverses CreateObject]("[/contents/1178-wsh-objet-wscript WScript].Shell")
            If Dir(Obj.SpecialFolders("desktop") & "\" & xdossier, vbDirectory) = "" Then
                  ' création du dossier dans le répertoire actuel
                  MkDir (Obj.SpecialFolders("desktop") & "\" & xdossier)
                  ' Message d'information
                
                  MsgBox "Le dossier " & xdossier & " a été créé."
             ' dans le cas contraire : si le dossier existe
            Else
                  ' Message d 'information
                  MsgBox "Création impossible. Le dossier " & xdossier & " existe déjà."
             ' Fin du test : si le nom du dossier n'existe pas ou existe dans le répertoire actuel
            End If
      ' Fin du test : si le double click est effectué sur la colonne D
      End If
      ' Active l'écran
      'Application.ScreenUpdating = True
      
     If Not Intersect(Target, Range("A2:A" & DerLig & ",I2:I" & DerLig)) Is Nothing Then
           
    End If
End Sub

1 réponse

  1.
    cs_Le Pivert Messages postés 8437 Statut Contributeur 730
     
    Bonjour,

    voir ceci:

    https://excel-malin.com/codes-sources-vba/creation-dossiers-et-sous-dossiers-en-vba/

    1
    1. novellina... Messages postés 2 Statut Membre
       
      merci pour ton aide.
      Seulement je n'arrive pas a voir ou le mettre ...
      0
    3. cs_Le Pivert Messages postés 8437 Statut Contributeur 730
       
      Voilà les 2 combinés à adapter : 

      Option Explicit
Dim chemin As String
Private Sub CommandButton1_Click()
ExempleTrouverCheminBureau
TesteSiDossierExiste
End Sub
Sub TesteSiDossierExiste()
'par Excel-Malin.com ( http://excel-malin.com )
Dim MonDossier As String
MonDossier = chemin & "\mondossier" 'adapter le nom du dossier, pour les sous-dossiers ajouter le nom du dossier se trouvant sur le bureau
If DossierExiste(MonDossier) = True Then
       ' MsgBox "Le dossier existe..."
    Else
      MkDir (chemin & "\mondossier") 'adapter le nom du dossier, pour les sous-dossiers ajouter le nom du dossier se trouvant sur le bureau
    End If
End Sub
Public Function DossierExiste(MonDossier As String)
 If Len(Dir(MonDossier, vbDirectory)) > 0 Then
      DossierExiste = True
   Else
      DossierExiste = False
   End If
End Function
Sub ExempleTrouverCheminBureau()
'par: https://excel-malin.com
On Error GoTo TestErreur
    Dim CheminBureau As String
    CheminBureau = ObtenirCheminBureau()
    chemin = CheminBureau 'affiche le chemin vers le dossier Bureau
    Exit Sub
TestErreur:
    MsgBox "Une erreur s'est produite..."
End Sub
Public Function ObtenirCheminBureau() As String
'par: Excel-Malin.com ( https://excel-malin.com )
 On Error GoTo ObtenirCheminBureauError
    Dim CheminBureau As String
    CheminBureau = ""
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
    CheminBureau = oWSHShell.SpecialFolders("Desktop")
     If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = CheminBureau
Exit Function
ObtenirCheminBureauError:
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = ""
End Function


      @+ Le Pivert
      0