Accueil

 

Commandes Dos courantes Liste des fichiers d'un répertoire (dossier) Synthèse de plusieurs classeurs Déplacement de fichiers d'un répertoire dans un autre Choix d'un fichier avec GetOpenFileName Choix d'un répertoire Arborescence d'un répertoire (dossier) ou du disque dur Recherche de fichiers avec FileSearch Liste des fichiers d'un répertoire Fonction Cellule("filename",A1) BuiltInDocumentsProperties Fonctions Diverses Création d'une arborescence de répertoires Remplacement de caractères dans les noms de répertoire Renomme des répertoires Remplace espaces noms de fichiers Renomme les fichiers d'un répertoire Divers

GetOpenFileName FileSearch FileSystemObject BuiltInDocumentsProperties CurDir ChDir Name Kill MkDir RmDir FileLen FileDateTime ChDrive Dir

Commandes et fonctions Dos courantes

Rep_courant=Curdir() donne le nom du répertoire courant
ChDir "c:\mes documents" modifie le répertoire courant
Name "x.xls" As "y.xls"  renomme le fichier
Kill "x.xls"  supprime le fichier
MkDir "essai"   crée un répertoire
RmDir "essai"   supprime le répertoire
FileLen("essai.xls") donne la taille
FileDateTime("essai.xls")   donne la date et l’heure de modification
ChDrive "D:" modifie l'unité active
FileCopy "c:\fichier.xls", "c:\fichierSauv.xls" copie le fichier spécifié

Dir(masque,attributs)

nom_fichier=Dir(masque) donne le nom du premier fichier du répertoire courant
correspondant au masque spécifié. Nom_fichier=Dir() donne le suivant. Lorsqu'il n'y a plus de
fichier, on obtient une chaîne vide.

nf=Dir("par*.xls") ' donne le nom du premier fichier commençant par 'Par'
nf=Dir() ' donne le fichier suivant

repertoire = "c:\xxx"
If Dir(repertoire, vbDirectory) = "" Then
  MsgBox "N'existe pas"
End If

Liste des fichiers d’un répertoire

Sur cet exemple, nous affichons la lsite des fichiers .Xls du répertoire courant

nf = Dir("*.xls") donne le nom du premier fichier du répertoire courant du type .Xls
nf=Dir() donne le nom du suivant

ListeFichiers.xls
ListeFichierChoixRépertoire

Sub ListeFichiers()
  Application.ScreenUpdating = False
  Range("A2:D65000").ClearContents
  repertoire = ThisWorkbook.Path & "\" ' adapter
  [H2] = repertoire
  ligne = 2
  nf = Dir(repertoire & "*.*") 'premier fichier xls
  Do While nf <> ""
    Cells(ligne, 1) = nf
    Cells(ligne, 2) = FileDateTime(nf)
    Cells(ligne, 3) = FileLen(nf)
    ligne = ligne + 1
    nf = Dir ' suivant
  Loop
End Sub

Avec FilesystemObject

Sub ListeFichiers()
  racine = "c:\mesdoc"
  Range("a4:F10000").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.getfolder(racine) 'DossierRacine
  ligne = 2
  For Each f In dossier.Files
    Cells(ligne, 1) = f.Name
    Cells(ligne, 2) = f.Size
    Cells(ligne, 3) = f.Datecreated
    Cells(ligne, 4) = f.DatelastModified
    Cells(ligne, 5) = f.Datelastaccessed
    If f.Attributes And vbHidden Then Cells(ligne, 6) = "Caché"
    ligne = ligne + 1
  Next
End Sub

Avec liens hypertexte

Sub ListeFichiersHyperTexte()
  Application.ScreenUpdating = False
  Range("A2:A65000").ClearContents
  repertoire = ThisWorkbook.Path & "\" ' adapter
  [H2] = repertoire
  ligne = 2
  nf = Dir(repertoire & "*.XLS") ' premier fichier xls
  Do While nf <> ""
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(ligne, 1), Address:=repertoire & "\" & nf, TextToDisplay:=nf
    ligne = ligne + 1
    nf = Dir ' fichier suivant
  Loop
  Range("a2:A" & [A65000].End(xlUp).Row).Sort key1:=[A2]
End Sub

Nombre de fichiers d'un répertoire et taille

repertoire = ThisWorkbook.Path & "\"
masque = repertoire & "*.xls"
nf = Dir(masque)
taille = 0
n = 0
Do While nf <> ""
  taille = taille + FileLen(repertoire & "\" & nf)
  n = n + 1
  nf = Dir()
Loop
MsgBox n
MsgBox taille

Copier des fichiers

Set Fs = CreateObject("Scripting.FileSystemObject")
Fs.CopyFile "c:\dell\*.*", "c:\dellx"

Copier un répertoire

'Cocher Microsoft Scripting RunTime
Dim fs As New Scripting.FileSystemObject
fs.GetFolder("c:\x").Copy "c:\y"

Déplacer un répertoire

'Cocher Microsoft Scripting RunTime
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFolder fs.GetFolder("c:\y"), "c:\xx\x"

Set Fs = CreateObject("Scripting.FileSystemObject")
Fs.CopyFolder "c:\mesdoc\excel\boisg", "c:\mesdoc\excel\coucho"

Taille d'un répertoire

Function TailleRepertoire(repertoire)
  Set fs = CreateObject("Scripting.FileSystemObject")
  TailleRepertoire = fs.GetFolder(repertoire).Size
End Function

Nombre de fichiers d'un répertoire

Function NombreFichiers(repertoire)
  Set fs = CreateObject("Scripting.FileSystemObject")
  NombreFichiers = fs.GetFolder(repertoire).Files.Count
End Function

Liste des répertoires d'un répertoire

Sub ListeRep()
  repertoire = "c:\mesdoc\"
  [A:A].ClearContents
  NomRep = Dir(repertoire, vbDirectory)
  i = 2
  Do While NomRep <> ""
     If NomRep <> "." And NomRep <> ".." Then
        If (GetAttr(repertoire & NomRep) And vbDirectory) = vbDirectory Then
           Cells(i, 1) = NomRep
           i = i + 1
        End If
     End If
     NomRep = Dir
  Loop
End Sub

Synthèse de plusieurs classeurs (vendeur1.xls,vendeur2.xls,....dans un seul)

Sur cet exemple, nous consolidons plusieurs classeurs d'un répertoire ayant un nom générique Vendeurxxx.xls dans un seul classeur.

Sub consolideClasseurs()
  ChDir ActiveWorkbook.Path
  Set classeurMaitre = ActiveWorkbook
  sup
  nf = Dir("vendeur*.xls")
  Do While nf <> ""
      Workbooks.Open Filename:=nf
      Sheets(1).Copy After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)
      classeurMaitre.Sheets(classeurMaitre.Sheets.Count).Name = nf
      Workbooks(nf).Close False
      nf = Dir     ' classeur suivant
  Loop
  Sheets(1).Select
End Sub

Sub sup()
  Application.DisplayAlerts = False
  If Sheets.Count > 1 Then
    Sheets("Accueil").Move before:=Sheets(1)
    Sheets(2).Select
    For i = 2 To Sheets.Count
      ActiveSheet.Delete
    Next i
  End If
End Sub

Déplacement de fichiers d'un répertoire dans un autre avec Name

On déplace dans un autre répertoire tous les fichiers dont le nom ne contiennent pas ABC.

Sub essai2()
  repertoire1 = "c:\toto\"
  repertoire2 = "c:\totobis\"
  nf = Dir(repertoire1 & "*.*")
  Do While nf <> ""
    If Not nf Like "*ABC*" Then
       Name repertoire1 & nf As repertoire2 & nf
    End If
    nf = Dir
  Loop
End Sub

Choix d’un fichier avec GetOpenFileName

La syntaxe est résultat=GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

On récupère le nom du fichier choisi ou False si l'opération a été annulée.

Sub choisir_fichier()
    nf = Application.GetOpenFilename("Fichiers Xls,*.xls")
    If Not nf = False Then
       Workbooks.Open FileName:=nf
    End If
End Sub

Plusieurs types de fichiers

Sub choisir_fichier()
  nf = Application.GetOpenFilename("Fichiers Excel ou Txt ,*.xls;*.txt")
  If Not nf = False Then
    Workbooks.Open FileName:=nf
  End If
End Sub

Choix multiples(avec ctrl)

On récupère un tableau avec les noms des fichiers choisis. On récupère False si l'opération a été annulée.

Sub choisir_fichier2()
  a = Application.GetOpenFilename(filefilter:=" Fichiers texte,*.txt", MultiSelect:=True)
  If VarType(a) <> vbBoolean Then
    For i = 1 To UBound(a)
      MsgBox a(i)
    Next i
  End If
End Sub

Choix d’un répertoire

Sub Dossier()
   With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ActiveWorkbook.Path & "\"
      .Show
      If .SelectedItems.Count > 0 Then
        choixDossier = .SelectedItems(1)
      Else
        choixDossier = ""
      End If
    End With
    MsgBox choixDossier
End Sub

Arborescence d'un répertoire (dossier) et ses fichiers (ou du disque dur)

Arborescence Répertoire/Fichiers.xls
Arborescence Répertoire/Fichiers copie.xls
Arborescence Répertoire hyper-liens.xls
Arborescence Répertoire Sous répertoire
Arborescence Répertoire Sous répertoire3
Arborescence Répertoire Sous répertoire3 colonnes
Arborescence Répertoire Sous répertoire Shapes
Arborescence Répertoire Sous Rep Fichiers

Dim ligne
Sub arborescence()
  Application.ScreenUpdating = False
  racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A3:E20000").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = 3
  Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
  Cells(ligne, 1) = String(4 * (niveau - 1), " ") & "[" & dossier.Path & "]"
  Cells(ligne, 2) =dossier.Size
  Cells(ligne, 4) = dossier.Files.Count
  Cells(ligne, 1).Interior.ColorIndex = 36
  ligne = ligne + 1
  For Each f In dossier.Files
     Cells(ligne, 1) = String(4 * niveau, " ") & f.Name
     Cells(ligne, 1).Interior.ColorIndex = xlNone
     Cells(ligne, 2) = f.Size
     Cells(ligne, 3) = f.DateLastModified
     Cells(ligne, 4) = f.Attributes
     If f.Attributes And vbHidden Then Cells(ligne, 5) = "Caché"
     ligne = ligne + 1
  Next
  For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
  Next
End Sub

Function ChoixDossier()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
     .InitialFileName = ActiveWorkbook.Path & "\"
     .Show
     If .SelectedItems.Count > 0 Then
       ChoixDossier = .SelectedItems(1)
     Else
       ChoixDossier = ""
     End If
   End With
  Else
     ChoixDossier = InputBox("Répertoire?")
   End If
End Function

Arborescence des sous-répertoires d'un répertoire

Arborescence Répertoire Sous Rep
Arborescence Répertoire Sous Rep 3
Arborescence Répertoire Sous Rep 3 colonnes

Pour limiter le nombre de niveaux à 2 par exemple, remplacer Lit_dossier d, niveau + 1 par

If niveau<=2 then Lit_dossier d, niveau + 1

Code
Dim ligne
Sub arborescenceRepertoire()
  racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
    Range("A:E").ClearContents
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dossier_racine = fs.getfolder(racine)
    ligne = 3
    Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = String(3 * (niveau - 1), " ") & dossier.Name
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
End Sub

Function ChoixDossier()
  If Val(Application.Version) >= 10 Then
   With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = ActiveWorkbook.Path & "\"
    .Show
    If .SelectedItems.Count > 0 Then
      ChoixDossier = .SelectedItems(1)
    Else
      ChoixDossier = ""
    End If
   End With
  Else
    ChoixDossier = InputBox("Répertoire?")
  End If
End Function

Arborescence Répertoire Sous Rep Fichiers

Arborescence des sous-répertoires d'un répertoire avec shapes

Peut être imprimé.

Arborescence Répertoire Sous répertoire Shapes
Arborescence Répertoire Sous répertoire FichiersvShapes

Arborescence des répertoires et ouverture d'un fichier choisi

-En cliquant sur le nom du répertoire, les noms des fichiers du répertoire choisi apparaissent dans une ListBox
-Cliquer sur le fichier choisi dans la ListBox
-Cliquer sur le bouton Ouvre (ou double-clic sur ListBox)

Arborescence répertoire choix fichier ouverture

Avec un TreeView

Arborescence Répertoire TreeView

Dim tw As MSComctlLib.TreeView, fs
Private Sub UserForm_Initialize()
  pere = ChoixDossier ' ou "C:\xxxxxx"
  If pere = "" Then Exit Sub
  If pere = "C:\" Then Stop
  Set tw = Me.MonArbre
  p = InStrRev(pere, "\"): tmp = Mid(pere, p + 1)
  tw.Nodes.Add(, , "NoeudMat" & pere, tmp).Expanded = True ' Racine arbre
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(pere)
  Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niv)
  pere = dossier.Path
  For Each d In dossier.SubFolders
    fils = d.Path
    p = InStrRev(fils, "\"): tmp = Mid(fils, p + 1)
    tw.Nodes.Add("NoeudMat" & pere, tvwChild, "NoeudMat" & d.Path, tmp).Expanded = True
    Lit_dossier d, niv + 1
  Next
End Sub

Avec des ListBoxs

Arborescence Répertoire Menu Form ListBox
Arborescence Répertoire Menu Tableur ListBox

Recherche de fichiers avec Filesearch

Recherche par nom

Sub essai()
  nf = InputBox("Fichier cherché?")
  If nf <> "" Then
    chemin = ThisWorkbook.Path
    RechercheFichiers chemin, nf
  End If
End Sub

Sub RechercheFichiers(chemin, monfichier)
   Set fs = Application.FileSearch
   fs.LookIn = chemin
   fs.SearchSubFolders = True
   fs.Filename = monfichier
   If fs.Execute() > 0 Then
      MsgBox "Il y a: " & fs.FoundFiles.Count & " Fichier(s)"
      For f = 1 To fs.FoundFiles.Count
        MsgBox fs.FoundFiles(f)
     Next f
   Else
     MsgBox "Pas de fichiers!"
   End If
End Sub

Recherche fichier par contenu

Sub essai2()
   contenu = InputBox("contenu cherché?")
   masque = InputBox("Masque *.xls")
   If masque = "" Then masque = "*.*"
   repertoire = InputBox("Répertoire?")
   If repertoire = "" Then repertoire = "c:\"
   If contenu <> "" Then
     RechercheContenu repertoire, contenu, masque
   End If
End Sub

Sub RechercheContenu(chemin, contenu, masque)
    Dim FS, I As Integer
    Set FS = Application.FileSearch
    FS.NewSearch
    FS.LookIn = chemin
    FS.SearchSubFolders = True
    FS.TextOrProperty = contenu
    FS.Filename = masque
    FS.MatchTextExactly = False
    If FS.Execute > 0 Then
      For I = 1 To FS.FoundFiles.Count
        MsgBox Application.FileSearch.FoundFiles(I)
      Next I
    End If
End Sub

Recherche un répertoire (FileSystemObject)

'Cocher Microsoft Scripting RunTime
Dim repCherché
Sub arborescence()
  racine = "c:\"
  repCherché = InputBox("Nom du répertoire cherché?")
  [A:A].Clear
  Range("A3").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
  Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   If UCase(dossier.Name) Like "*" & UCase(repCherché) & "*" Then
     ActiveCell.Value = dossier.Path
     ActiveCell.Offset(1, 0).Select
   End If
   On Error Resume Next
   For Each d In dossier.SubFolders
      Lit_dossier d, niveau + 1
   Next
End Sub

Sous répertoires du répertoire actuel

Sub SousRepRepActuel()
   [a:a].Clear
   Racine = CurDir                    ' Répertoire courant
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set Dossier = fs.getfolder(Racine)
   [A1].Select
   For Each d In Dossier.SubFolders
     ActiveCell = d.Name
     ActiveCell.Offset(1, 0).Select
   Next
End Sub

Arborescence des sous-répertoires du répertoire actuel

Sub ArborescenceRepertoire()
  Racine = CurDir                      ' Répertoire courant
  Range("A:A").Clear
  Range("A1").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set DossierRacine = fs.getfolder(Racine)
  LitDossier DossierRacine, 1
End Sub

Sub LitDossier(ByRef Dossier, ByVal Niveau)
   ActiveCell.Value = String(3 * (Niveau - 1), " ") & Dossier.Name & "[" & Dossier.Path & "]"
   ActiveCell.Offset(1, 0).Select
   For Each d In Dossier.SubFolders
     LitDossier d, Niveau + 1
   Next
End Sub

Tester si un fichier est déjà ouvert

fichier="Essai.xls"
On Error Resume Next
Open fichier For Input Lock Read As #1
Close #1
If Err = 70 Then
  MsgBox "Fichier ouvert"
  Exit Sub
End If
On Error GoTo 0

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Private Sub UserForm_Initialize()
  Me.Répertoire = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir(Me.Répertoire & "\*.*") ' premier
  n = 0
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir ' suivant
    n = n + 1
  Loop
  Me.nbFichiers = n
End Sub

Private Sub ChoixFichier_Click()
  Me.FichierChoisi = Me.ChoixFichier
End Sub

Private Sub B_ok_Click()
   On Error Resume Next
   Name ChoixFichier As Me.FichierChoisi
  UserForm_Initialize
End Sub

Private Sub b_dossier_Click()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = CurDir()
      .Show
      If .SelectedItems.Count > 0 Then
        Me.Répertoire = .SelectedItems(1)
        ChDir Me.Répertoire
      Else
        Me.Répertoire = ""
      End If
      UserForm_Initialize
    End With
  Else
     DossierChoisi = VoirDossier("Choisir le dossier")
     If DossierChoisi <> "" Then
       Me.Répertoire = DossierChoisi
       ChDir DossierChoisi
   End If
   UserForm_Initialize
  End If
End Sub

Autre version

Liste fichiers répertoire

Private Sub UserForm_Initialize()
  If Me.répertoire = "" Then Me.répertoire = ThisWorkbook.Path
  Dim Tbl()
  nf = Dir(Me.répertoire & "\*.*")
  n = 0
  Do While nf <> ""
    n = n + 1
    ReDim Preserve Tbl(1 To 2, 1 To n)
    Tbl(1, n) = nf
    Tbl(2, n) = Format(FileDateTime(Me.répertoire & "\" & nf), "yyyy/mm/dd hh:mm")
    nf = Dir
  Loop
  If n > 0 Then
    If n > 1 Then
       Me.ListBox1.List = Application.Transpose(Tbl)
    Else
       Dim aa(1 To 1, 1 To 2)
       aa(1, 1) = Tbl(1, 1): aa(1, 2) = Tbl(2, 1)
       Me.ListBox1.List = aa
    End If
  End If
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
  Me.TypeFich.List = Array("*.*", "*.xls", "*.jpg", "*.mdb", "*.txt")
  Me.TypeFich.ListIndex = 0
End Sub

Private Sub B_triNom_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 0, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub B_triDate_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 1, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
End Sub

Private Sub b_tridateDesc_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call Quick(a(), LBound(a), UBound(a), 1, False)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub TypeFich_Change()
  Dim Tbl()
  nf = Dir(Me.TypeFich)
  n = 0
  Do While nf <> ""
     n = n + 1
     ReDim Preserve Tbl(1 To 2, 1 To n)
     Tbl(1, n) = nf
     Tbl(2, n) = Format(FileDateTime(nf), "yyyy/mm/dd hh:mm")
     nf = Dir
  Loop
  If n > 0 Then
     If n > 1 Then
        Me.ListBox1.List = Application.Transpose(Tbl)
     Else
        Dim aa(1 To 1, 1 To 2)
        aa(1, 1) = Tbl(1, 1): aa(1, 2) = Tbl(2, 1)
        Me.ListBox1.List = aa
     End If
  End If
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
End Sub

Private Sub B_répertoire_Click()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = CurDir()
    .Show
    If .SelectedItems.Count > 0 Then
      Me.répertoire = .SelectedItems(1)
    Else
      Me.répertoire = ""
    End If
    ChDir Me.répertoire
    UserForm_Initialize
   End With
  Else
    DossierChoisi = VoirDossier("Choisir le dossier")
    If DossierChoisi <> "" Then
        Me.répertoire = DossierChoisi
    End If
    ChDir Me.répertoire
    UserForm_Initialize
  End If
End Sub

Sub Quick(a(), gauc, droi, col, ordre) ' Quick sort
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    Do While IIf(ordre, a(g, col) < ref, a(g, col) > ref): g = g + 1: Loop
    Do While IIf(ordre, ref < a(d, col), ref > a(d, col)): d = d - 1: Loop
    If g <= d Then
      For i = LBound(a, 2) To UBound(a, 2)
         temp = a(g, i): a(g, i) = a(d, i): a(d, i) = temp
      Next i
      g = g + 1: d = d - 1
   End If
  Loop While g <= d
  If g < droi Then Call Quick(a, g, droi, col, ordre)
  If gauc < d Then Call Quick(a, gauc, d, col, ordre)
End Sub

CELLULE("filename";A1)

La fonction CELLULE("filename";A1) donne Répertoire+nom_fichier+nom_onglet:

C:/fichiers/[CelluleNomFichier.xls]Feuil1

Nom de l'onglet:
=STXT(CELLULE("filename";A1);TROUVE("]";CELLULE("filename";A1))+1;99)

Chemin+nomFichier:
=GAUCHE(CELLULE("filename";A1);TROUVE("]";CELLULE("filename";A1)))
-->C:\mesdoc\excelmacronouveau\1001exemples\[Classeur1.xls]

=SUBSTITUE(SUBSTITUE(GAUCHE(CELLULE("filename";A1);TROUVE("]";CELLULE("filename";A1)));"[";"");"]";"")
-->C:\mesdoc\excelmacronouveau\1001exemples\Classeur1.xls

Nom du fichier:
=STXT(CELLULE("filename";A1);TROUVE("[";CELLULE("filename";A1))+1;TROUVE("]";
CELLULE("filename";A6))-TROUVE("[";CELLULE("filename";A1))-1)

Nombre de feuilles d'un classeur et noms des feuilles avec Macro XL4

Pour obtenir le nombre de feuilles d'un classeur

-Créer un nom de champ NbFeuilles
=LIRE.CLASSEUR(4)
Dans une cellule du tableur
=NbFeuilles+(MAINTENANT()=1)

Pour obtenir les noms des feuilles d'un classeur:

-Créer un nom de champ NomsFeuilles
=LIRE.CLASSEUR(1)
-Sélectionner des cellules horizontales
=SI(MAINTENANT()>0;STXT(NomsFeuilles;TROUVE("]";NomsFeuilles)+1;99))
-Valider avec Maj+Ctrl+entrée

Liste des fichiers d'un répertoire avec Excel4

Créer un nom de champ

Liste =FICHIERS("C:\mesdoc\excel\fichiers\fichier\*.xls")

En A2, =SI(LIGNES($1:1)<=NBVAL(Liste);INDEX(Liste;LIGNES($1:1));"")

ListeFichiers

BuiltinDocumentProperties

Sub propriétés()
  For i = 1 To 30
    On Error Resume Next
    Cells(i, 1) = ActiveWorkbook.BuiltinDocumentProperties.Item(i).Name
    Cells(i, 2) = ActiveWorkbook.BuiltinDocumentProperties.Item(i)
  Next i
End Sub

7 Last author Boisgontier
8 Revision number
9 Application name Microsoft Excel
10 Last print date
11 Creation date 13/8/07 1:55 PM
12 Last save time 13/8/07 1:57 PM

Fonctions diverses

Function DateCreationFichier(nf)
  Dim fs, f
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.GetFile(nf)
  DateCreationFichier = f.DateCreated
End Function

Function DateModifFichier(nf)
  DateModifFichier = FileDateTime(nf)
End Function

Function DernièreSauvegardeClasseur()
  Application.Volatile
  DernièreSauvegardeClasseur = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function

Function CreationClasseurActuel()
  Application.Volatile
  CreationClasseurActuel = ThisWorkbook.BuiltinDocumentProperties("Creation date")
End Function

Boîtes de dialogue Excel

Application.Dialogs(xlDialogSaveAs).Show
ActiveWorkbook.Close SaveChanges:=False
nf = Application.Dialogs(xlDialogOpen).Show
z = Application.Dialogs(xlDialogSendMail).Show

Unité clé USB

Sub essai()
  If Len(ListeUsb()) = 2 Then
    fichier = Dir(ListeUsb() & "\*.*")
    Do While fichier <> ""
      MsgBox fichier
      fichier = Dir
    Loop
  End If
End Sub

Function ListeUsb()
  Set fs = CreateObject("Scripting.FileSystemObject")
  temp = ""
  For Each d In fs.Drives
    If d.DriveType = 1 Then
      If d.IsReady Then temp = temp & d.DriveLetter & ":"
    End If
  Next
  ListeUsb = temp
End Function

Création d'une arborescence de répertoires

Pour créer une branche d'arborescence C:\monrep\essai1\Essai2

Sub essai()
   CreationDossier "C:\monrep\essai1\Essai2"
End Sub

Sub CreationDossier(chemin)
  a = Split(chemin, "\")
  tmp = a(0) & "\"
  For i = LBound(a) + 1 To UBound(a)
    tmp = tmp & a(i) & "\"
    If Dir(tmp, vbDirectory) = "" Then MkDir tmp
  Next i
End Sub

Pour créer une arborecence compléte

Crée Arborescence de répertoires
Transforme organigramme en BD

Dim n, ligne, Tbl(), RepNiv(1 To 6)
Sub CreeArboRepertoire()
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  n = UBound(Tbl)
  niv = 1
  CréeRep Tbl(1, 1), niv
End Sub

Sub CréeRep(parent, niv)     ' procédure récursive
  chemin = ""
  RepNiv(niv) = parent
  For i = 1 To niv
  chemin = chemin & RepNiv(i) & "\"
  Next i
  MkDir chemin
  For i = 1 To n
    If Tbl(i, 2) = parent Then CréeRep Tbl(i, 1), niv + 1
  Next i
End Sub

Remplacement de caractères dans les noms de répertoire

Remplace les espaces par le caractère _ dans les noms de répertoire

Remplacement caractère

Dim ligne, nivMax, debOrg
Sub arborescenceRepertoire()
  racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A2:A30000").ClearContents
  lignedeb = 2
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = lignedeb
  nivMax = 4
  Lit_dossier dossier_racine, 1, nivMax, ""
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau, ByVal nivMax, parent)
   Cells(ligne, 1) = dossier.Path
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     If niveau <= nivMax Then Lit_dossier d, niveau + 1, nivMax, dossier.Path
   Next
End Sub

Function ChoixDossier()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ActiveWorkbook.Path & "\"
      .Show
     If .SelectedItems.Count > 0 Then
        ChoixDossier = .SelectedItems(1)
     Else
        ChoixDossier = ""
     End If
   End With
  Else
     ChoixDossier = InputBox("Répertoire?")
  End If
End Function

Sub modifie()
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  For Each c In Rng
    chemin1 = c.Value
    chemin2 = Replace(c.Value, " ", "_")
    Name chemin1 As chemin2
    Rng.Replace chemin1, chemin2
  Next c
End Sub

Renomme des répertoires

Renomme des répertoires

Sub modifie()
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  For Each c In Rng
    chemin1 = c.Value
    chemin2 = c.Offset(, 1).Value
    If chemin2 <> chemin1 Then
       Name chemin1 As chemin2
       Rng.Replace chemin1, chemin2
       Set Rng2 = Range("A" & c.Row + 1 & ":A" & [A65000].End(xlUp).Row)
       Rng2.Offset(, 1).Replace chemin1, chemin2
     End If
   Next c
End Sub

Remplace les espaces par des _ dans les noms fichiers

Remplace espace noms fichiers

Renomme les fichiers d'un répertoire

Liste Fichiers Répertoire Renomme

Divers

SauvegardeSaveCopyAs
Choix répertoire
FonctionListeFichiersRepertoire
Sauvegarde onglet classeur
SauvegardeDateJour
SauvegardeIndice
SauvegardeRepertoireUser
FichierPlusRecent
DateDernièreModif
CelluleNomFichier
ListeFichiersRépCommencePar