[Excel VBA] Créer Des Dossiers Sous VBA - Comment Ça Marche

Informatique Mobile Applis & Sites Image & Son Maison Securité Téléchargement Forum Bureautique Développement Internet Jeux vidéo Matériel Réseau Vidéo/TV Virus/Sécurité Emploi

• Forum
• Informatique & Design
• Programmation
• VB / VBA

Bonjour à tous, Je souhaiterais ajouter une commande à l’un de mes codes VBA qui crée un dossier si celui n’existe pas. J’utilise sans problème la commande mkdir pour créer le dossier, mais pas la commande folderexists pour vérifier préalablement qu’il n’existe pas (à dire vrai je ne comprends ni l’aide de VBA, ni celle de Microsoft Online pour cette commande). Quelqu’un pourrait-il m’aider ? Juste une dernière chose, le nom du dossier n’est pas fixe. Ma commande mkdir est par exemple : MkDir ("test\" & Cells(1, 1).Value) D’avance merci ! Afficher la suite Répondre (8) Partager

• Copier

A voir également:

• Mkdir vba
• Mkdir - p signification ✓ - Forum Linux / Unix
• [VBA] Création dossier MkDir ✓ - Forum VB / VBA
• Commande DOS : MKDIR - Forum Windows
• Mkdir php ✓ - Forum PHP
• Incompatibilité de type vba ✓ - Forum Programmation

Réponse 1 / 8 Meilleure réponse La meilleure réponse est la réponse qui a été validée par nos équipes. approuvée par Jean-François Pillou Une fonction qui fait ce que tu veux : 'Fonction qui vérifie si le dossier spécifié existe Function RepertoireExiste(Chemin As String) As Boolean On Error Resume Next RepertoireExiste = GetAttr(Chemin) And vbDirectory End Function Après, il n'y a plus qu'à tester : If Not (RepertoireExiste(Name)) Then Bonjour, Reprenant cette idée, j'ai simplement ajouté "On Error Resume Next " avant la commande mkdir Pour l'instant, cela suffit Dred Réponse 2 / 8 Bonjour, Voci un exemple de balayage récursif, mais il vous faudra l'adapter à vos besoin ! Ce code est en VBS, mais il devrait vous être facile de l'implanter en VBA, par défaut sous VBS toutes les variable sont de type Variant, à moins d'être sur de bien comprendre la type de la variable je vous recommande de la typé en Variant sous VBA. Pour l'implantation vous n'aurez qu'a remplacer les objets de scripting par le objets Excel. ex.: Set xlApp = CreateObject("Excel.Application") devient ActiveWorkbook.Activate Set xlBook = xlApp.Workbooks.Open(Fichier) devient Workbooks.Open(Fichier) etc ... '===============================================================' ' Fichier Source VBScript ' ' NOM DU FICHIER : <ARBORESCENCE_Sous_EXCEL.VBS> ' ' AUTEUR : Arsène Lupin ' DATE DE CRÉATION : 2002-11-05 ' DATE DE MODIFICATION : 2006-01-17 ' Version 3.1 ' ' COMMENT: <Compiler dans un fichier EXCEL toutes les informations ' des fichiers d'un lecteur et/ou d'un répertoire cible '=================================================================' ' 'Accèss au dossier d'un disque ' Const cteCache = "Caché" Const cteSysteme = "Système" Const cteArchive = "cteArchive" Const cteLecture = "cteLecture_Seulement" Const cteRaccourci = "cteRaccourci" Const cteCompresse = "Compressé" Const ctePlgFitGlobale = "A1:P1" ' ==================================================================' ' Déclaration des variables globales du programme ' Dim oLecteur 'ObjetLecteurDeDisque Dim oRepertoire 'ObjetRépertoire Dim oFS 'ObjetFileSystem (Objet du système de fichier) Dim sOutput 'Variable d'écriture Dim oInfoLecteur 'Variable d'information sur le lecteur courant Dim oInfoFichier 'Variable d'information sur le fichier courant Dim Lecteur 'Variable du lecteur à lire Dim Disque 'Variable du lecteur à écrire Dim Fichier 'Variable du fichier de sortie Dim Flag 'Drapeau (logique) Dim msgTexte 'Variable de message è l'usager Dim lngTexte 'Variable de la longueur d'une chaine de caractères Dim Dossier 'Variable chaine du dossier de départ Dim DonneesValide 'Variable de la valeur des saisies '================================================================= ' Déclaration des variables globales du classeur EXCEL ' Dim xlApp, xlBook, xlChart, xlRange 'Objets classeur Dim xlWhs, iRows, iCols, iRotate 'Objets feuille ' '================================================================= ' Debut du programme ' 'Sub Main()' (Attention, le label n'exite pas en VBS) DonneesValide = CaptureEntree(Fichier,Lecteur,Dossier) If ( DonneesValide ) Then ' Création de l'objet Excel (une classe) Set oFS = CreateObject("Scripting.FileSystemObject") Set xlApp = CreateObject("Excel.Application") ' Vérification de la présence du classeur If (FichierExistant(Fichier) = True) Then ' Ouverture du classeur Set xlBook = xlApp.Workbooks.Open(Fichier) Flag = True Else ' Création du classeur xlApp.SheetsInNewWorkbook = 1 Set xlBook = xlApp.Workbooks.Add End If ' Positionnement à l'intérieur du classeur Set xlWKS = xlBook.Worksheets(1) Set xlRange = xlWKS.Range("A1:A65535") ' Capture de la lettre du lecteur à écrire Disque = Mid(Fichier, 1, 2) Set oLecteur = oFS.GetDrive(Disque) If (oLecteur.IsReady) Then ' Capture de la lettre du lecteur à lire Set oLecteur = oFS.GetDrive(Lecteur) If (oLecteur.IsReady) Then Call Principal(Fichier) Else EnvoiMessage (0) End If Else EnvoiMessage (0) End If End if ' 'End Sub (Le label n'exite pas en VBS) Fin de Programme ' '=============================================================== ' Function CaptureEntree(ByRef FichierCE, ByRef LecteurCE, ByRef DossierCE) On Error Resume next Flag = False FichierCE = "" msgTexte = msgTexte & "Attention!" & vbCrLf & vbCrLf msgTexte = msgTexte & "Le programme ne gère pas les erreurs!" & vbCrLf & vbCrLf & vbCrLf msgTexte = "Entrez le nom du fichier : " & vbCrLf & "(ex.: C:\Infofile.xls)" FichierCE = InputBox(msgTexte, "Saisie du fichier à créer", "C:\Info.xls") If ( len(FichierCE) > 7 ) Then LecteurCE = "" LecteurCE = InputBox("Entrez la lettre du lecteur à lire :", "Saisie du lecteur à lire", "C") If ( Len(LecteurCE) = 1 ) Then DossierCE = "" DossierCE = InputBox("Entrez le dossier cible du lecteur à lire :", "Saisie du dossier à lire", "\TEMP") If ( len(DossierCE) > 1 ) Then CaptureEntree = True Else DossierCE = "" CaptureEntree = true End If Else CaptureEntree = False End If Else CaptureEntree = False End if End Function ' '================================================================= ' Sub Principal(ByVal NomFichier) Dim Plage Dim Valeur Dim Boucle On Error Resume Next ' Création de l'En-tête du fichier Excel Call CreationEnTete 'Placement d'Excel en arrière plan! xlApp.WindowState = xlMinimized xlApp.ScreenUpdating = False If (oLecteur.IsReady) Then If (Dossier <> "") Then 'cteLecture à partir du sous-répertoire cible Set oRepertoire = oFS.GetFolder(Lecteur & ":" & Dossier) xlApp.Visible = True xlWKS.Activate xlRange.Cells(1, 1).Select Call ListeFichier(oRepertoire) ' Routine récursive Else 'cteLecture des fichiers dans la racine du lecteur If (oLecteur.RootFolder.Files.Count > 0) Then For Each oFichier In oLecteur.RootFolder.Files InsertionDonnees (oFichier) Next End If 'cteLecture des sous-répertoires dans le lecteur For Each oRepertoire In oLecteur.RootFolder.SubFolders xlApp.Visible = True xlWKS.Activate xlRange.Cells(1, 1).Select Call ListeFichier(oRepertoire) ' Routine récursive Next End If End If MiseEnforme 'Placement d'Excel en avant plan! xlApp.ScreenUpdating = True xlApp.WindowState = xlMaximized xlRange.Columns("A:A").EntireColumn.AutoFit xlRange.Columns("E:G").EntireColumn.AutoFit 'Fermeture du fichier Excel Call FermetureExcel() wscript.echo "Fin de traitement :-) " End Sub ' '=============================================================== ' Function FichierExistant(NomFichier) Dim fso Set fso = CreateObject("Scripting.FileSystemObject") FichierExistant = fso.FileExists(NomFichier) Set fso = Nothing End Function ' '=============================================================== ' Function EnvoiMessage(ByVal Chiffre) Select Case Chiffre Case 0: msgTexte = "Lecteur non disponible !" Case 1: msgTexte = "Disponible !" Case 2: msgTexte = "Disponible !" Case 3: msgTexte = "Disponible !" Case 4: msgTexte = "Disponible !" Case 5: msgTexte = "Disponible !" Case 6: msgTexte = "Disponible !" Case Else: msgTexte = "Code d'erreur inexistant !" End Select Wscript.Echo msgTexte End Function ' '========================================================= ' Sub ListeFichier(ByVal oRepertoire) ' Routine récursive Dim oDossier On Error Resume Next If (oRepertoire.Files.Count > 0) Then For Each oFichier In oRepertoire.Files InsertionDonnees (oFichier) Next End If If (oRepertoire.SubFolders.Count > 0) Then For Each oDossier In oRepertoire.SubFolders Call ListeFichier(oDossier) Next End If End Sub ' '=========================================================== ' Function ChercheAttributs(ByVal oFichier, ByVal Validation, ByRef Repons) On Error Resume Next Repons = "Aucun" Select Case (Validation) Case (cteLecture): If (oFichier.Attributes And 1) Then Repons = "Activer" 'Read-only = VRAI Else Repons = "Désactiver" 'Read-only = FAUX End If Case (cteCache): If (oFichier.Attributes And 2) Then Repons = "Activer" 'Hidden file = VRAI Else Repons = "Désactiver" 'Hidden file = FAUX End If Case (cteSysteme): If (oFichier.Attributes And 4) Then Repons = "Activer" 'System file = VRAI Else Repons = "Désactiver" 'System file = FAUX End If Case (cteArchive): If (oFichier.Attributes And 32) Then Repons = "Activer" 'cteArchive bit = VRAI Else Repons = "Désactiver" 'cteArchive bit = FAUX End If Case (cteRaccourci): If (oFichier.Attributes And 64) Then Repons = "Activer" 'ShortCut = VRAI Else Repons = "Désactiver" 'ShortCut = FAUX End If Case (cteCompresse): If (oFichier.Attributes And 2048) Then Repons = "Activer" 'cteCompressed file = VRAI Else Repons = "Désactiver" 'cteCompressed file = FAUX End If Case Else: Repons = "Aucun" End Select End Function ' '======================================================= ' Function CreationEnTete() Dim Valeur Dim Boucle On Error Resume Next If (Flag = False) Then 'Création de l'en-tête du fichier EXCEL xlRange.Cells(1, 1).Value = "Nom Fichier" xlRange.Cells(1, 2).Value = "Type Fichier" xlRange.Cells(1, 3).Value = "Grandeur" xlRange.Cells(1, 4).Value = "Chemin d'accès" xlRange.Cells(1, 5).Value = "Date Créé" xlRange.Cells(1, 6).Value = "Date Accédé" xlRange.Cells(1, 7).Value = "Date Modifié" xlRange.Cells(1, 8).Value = "Nom cours" xlRange.Cells(1, 9).Value = "Chemin cours" xlRange.Cells(1, 10).Value = "Version" xlRange.Cells(1, 11).Value = "Attr Caché" xlRange.Cells(1, 12).Value = "Attr Système" xlRange.Cells(1, 13).Value = "Attr Archive" xlRange.Cells(1, 14).Value = "Attr Lecture seule" xlRange.Cells(1, 15).Value = "Attr Raccourci" xlRange.Cells(1, 16).Value = "Attr compressé" ' Dans Sub MiseEnForme la plage est ("A1:P1") ' Défini par la constante ctePlgFitGlobale iRows = 2 Else Boucle = 1 Valeur = xlRange.Cells(1, 1).Value While (Valeur <> "") Boucle = (Boucle + 1) Valeur = xlRange(Boucle, 1) Wend iRows = Boucle End If End Function ' '================================================================ ' Function MiseEnForme() xlRange.Columns(ctePlgFitGlobale).EntireColumn.AutoFit xlRange("A2").Select End Function ' '========================================================== ' Function InsertionDonnees(ByVal CeFichier) On Error Resume Next Dim Reponse xlRange.Cells(iRows, 1).Value = CeFichier.Name xlRange.Cells(iRows, 2).Value = CeFichier.Type xlRange.Cells(iRows, 3).Value = CeFichier.Size xlRange.Cells(iRows, 4).Value = CeFichier.Path xlRange.Cells(iRows, 5).Value = CeFichier.DateCreated xlRange.Cells(iRows, 6).Value = CeFichier.DateLastAccessed xlRange.Cells(iRows, 7).Value = CeFichier.DateLastModified xlRange.Cells(iRows, 8).Value = CeFichier.ShortName xlRange.Cells(iRows, 9).Value = CeFichier.ShortPath xlRange.Cells(iRows, 10).Value = ChercheVersion(CeFichier.Name) Call ChercheAttributs(CeFichier, cteCache, Reponse) xlRange.Cells(iRows, 11).Value = Reponse Call ChercheAttributs(CeFichier, cteSysteme, Reponse) xlRange.Cells(iRows, 12).Value = Reponse Call ChercheAttributs(CeFichier, cteArchive, Reponse) xlRange.Cells(iRows, 13).Value = Reponse Call ChercheAttributs(CeFichier, cteLecture, Reponse) xlRange.Cells(iRows, 14).Value = Reponse Call ChercheAttributs(CeFichier, cteRaccourci, Reponse) xlRange.Cells(iRows, 15).Value = Reponse Call ChercheAttributs(CeFichier, cteCompresse, Reponse) xlRange.Cells(iRows, 16).Value = Reponse iRows = (iRows + 1) If (iRows > 65534) Then xlApp.ActiveWorkbook.Worksheets.Add Set xlWKS = xlBook.Worksheets(1) Set xlRange = xlWKS.Range("A1:A65535") iRows = 2 End If End Function ' '=============================================================== ' Function FermetureExcel() xlApp.Visible = True xlWKS.Activate xlRange.Cells(1, 1).Select xlApp.DisplayAlerts = False xlBook.SaveAs Fichier xlApp.Quit xlApp.DisplayAlerts = True Set xlRange = Nothing Set xlChart = Nothing Set xlWKS = Nothing Set xlBook = Nothing Set xlApp = Nothing iRows = 0 iCols = 0 End Function ' Lupin Réponse 3 / 8 Bonjour, voici un exemple tiré de l'aide pour balayer le contenu d'un dossier à la recherche des sous-dossiers ! Sub text() Dim Chemin As String, NomRep As String Chemin = "C:\" ' Définit le chemin d'accès. NomRep = Dir(Chemin, vbDirectory) ' Extrait la première entrée. Do While NomRep <> "" ' Commence la boucle. ' Ignore le dossier courant et le dossier ' contenant le dossier courant. If NomRep <> "." And NomRep <> ".." Then ' Utilise une comparaison au niveau du bit pour ' vérifier que NomRep est un dossier. If (GetAttr(Chemin & NomRep) _ And vbDirectory) = vbDirectory Then MsgBox NomRep ' Affiche l'entrée uniquement si elle End If ' représente un dossier. End If NomRep = Dir ' Extrait l'entrée suivante. Loop End Sub ' Lupin Do While NomRep <> "" If NomRep <> "." And NomRep <> ".." Then j'aurais voulu savoir que renseigne les <> dans cette chaine si quelqu'un peu me repondre merci different de ( pas egal quoi) Réponse 4 / 8 Bonsoir essaie Dim NomRep As String NomRep = "c:\" & ActiveCell.Value MkDir NomRep activecell.value fait reférence à la cellule ou se trouve le nom du nouveau sous repertoire c:\ peut etre remplacé par le chemin souhaité du repertoire parent

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question Réponse 5 / 8 Merci beaucoup de m'aider, mais ma question n'est pas celle-là. Créer le dossier je sais faire. C'est vérifier au préalable qu'il existe que je ne sais pas faire :/ Réponse 6 / 8 Bonjour, Moi j'aurai vérifier si il y a des données sous un dossier et ses sous-dossiers. Est ce que vous avez une idée ? Réponse 7 / 8 Je te propose une petite fonction qui va tester les noms des sous-répertoires présents dans un dossier. En revanche cette fonction s’arrête au premier niveau de sous répertoire, si cela peut t’aider … Function TestDossier(LeDossier$, nom_recherche As String) As Boolean Set fso = CreateObject("Scripting.FileSystemObject") Set Dossier = fso.GetFolder(LeDossier) For Each flder In Dossier.subfolders If Right(flder, Len(flder) - Len(LeDossier)) = nom_recherche Then TousLesDossiers = True Exit For End If Next Set fso = Nothing End Function Réponse 8 / 8 j'ai exactement le même problème quelqu'un a une réponse ? bonjour à tous, J'ai fait le tour de plusieurs forums et je n'arrive tjs pas à aboutir. Je suis novice sous vba et j'aurai besoin d'aide pour : A partir d'un onglet / copier onglet dans un nouveau répertoire avec pour le nom du dossier la valeur d'une cellule et pour le nom du fichier la valeur d'une autre cellule. J'ai réussi à coder le copier coller + nouveau nom du fichier dans un répertoire. Là ou je bloque c'est pour d'abord créer le dossier puis enregistrer le fichier dedans. code déjà fait : Range("A1:AK38").Select Selection.Copy Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveWindow.Zoom = 115 ActiveWindow.Zoom = 130 ActiveWindow.Zoom = 145 ActiveWindow.Zoom = 160 ActiveWindow.DisplayGridlines = False Chemin = "réseau" ActiveWorkbook.SaveAs Chemin & [G4] & "-" & [G3] & "-documentation" & ".xls" ActiveWindow.Close Range("Aq11").Select ActiveCell.FormulaR1C1 = "Fichier " & [G4] & " Enregistré" Range("AP11:BC11").Select Selection.Font.Bold = True With Selection.Interior .ColorIndex = 36 .Pattern = xlSolid End With Selection.Font.ColorIndex = 50 Range("R4").Select Selection.ClearContents Range("D16:D29").Select Selection.ClearContents pour la création du dossier, j'ai repris cela : la macro tourne mais rien ne ce passe... Private Sub CommandButton4_Click() If Dir(ThisWorkbook.Path & [D13], vbDirectory) = "P:\Tcrsra\SRA_2\PDF-AFFAIRES-SRA2\Documentation fin d'affaire\" Then MkDir ThisWorkbook.Path & [D13] ThisWorkbook.SaveCopyAs ThisWorkbook.Path & [D13] & Format(Date, "YYYYMMDD") & "_" & Format(Now, "HHMMSS") & ".xls" End Sub Comment combiner les deux ???? Afficher toute la discussion

Votre réponse

Discussions similaires

[excel] feuille active VBA/Excel Instruction: On Error Resume Next [VBA Excel] nb cells non vide dans une colonn [VBA] Incrementer une variable [VBA] Fermeture avec enreg sans boite de dial [Excel Vba] Insérer une ligne Devenez membre en quelques clics

• Connectez-vous simplement avec ceux qui partagent vos intérêts
• Suivez vos discussions facilement et obtenez plus de réponses
• Mettez en avant votre expertise et aidez les autres membres
• Profitez de nombreuses fonctionnalités supplémentaires en vous inscrivant

Newsletters

Newsletters Actu du jour Voir un exemple

Les informations recueillies sont destinées à CCM BENCHMARK GROUP pour vous assurer l'envoi de votre newsletter.

De plus, lors de votre inscription sur ce formulaire, des données personnelles (dont votre adresse email sous forme hachée et pseudonymisée) peuvent être partagées avec nos partenaires Data à des fins de personnalisation de la publicité et des contenus qui vous sont proposés. Vous trouverez le détail de ces informations et pouvez vous y opposer à tout moment.

Plus généralement, vous bénéficiez d'un droit d'accès et de rectification de vos données personnelles, ainsi que celui d'en demander l'effacement dans les limites prévues par la loi.

Vous pouvez également à tout moment revoir vos options en matière de prospection commerciale et ciblage. En savoir plus sur notre politique de confidentialité ou notre politique Cookies.