[Excel VBA] Créer des dossiers sous VBA [Résolu]

Réponse 2 / 8

Utilisateur anonyme
23 juil. 2007 à 16:26

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

Utilisateur anonyme
17 mai 2007 à 15:36

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

bob
17 janv. 2011 à 16:10

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

phil
8 févr. 2011 à 19:41

different de ( pas egal quoi)

Réponse 4 / 8

sncf Messages postés 121 Date d'inscription lundi 7 juillet 2003 Statut Membre Dernière intervention 11 septembre 2011 14
15 mai 2007 à 23:03

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

Kvo Messages postés 27 Date d'inscription mercredi 28 février 2007 Statut Membre Dernière intervention 22 mai 2008 3
17 mai 2007 à 12:54

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

yoyovento
23 juil. 2007 à 14:03

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

themayu Messages postés 7 Date d'inscription jeudi 16 juin 2005 Statut Membre Dernière intervention 28 août 2007
28 août 2007 à 23:30

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

bob
17 janv. 2011 à 15:42

j'ai exactement le même problème quelqu'un a une réponse ?

grec38
Modifié par grec38 le 26/01/2012 à 15:44

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 ????

[Excel VBA] Créer des dossiers sous VBA

8 réponses

Discussions similaires

Newsletters