VBA Liste Fichier: Mise en forme tableau et Nom de fichier partiel

Le 08/08/2021 à 17:16

Bonjour,

Je débute en VBA et en compilant des bouts de code que j'ai trouvé ou créer je suis arrivé au code ci-dessous pour créer ma liste de fichier, le but étant de créer un tableau de données qui sera exploité par d'autre fichier excel.

Option Explicit
    Dim cible As Byte

 Sub Extraction()
    Dim Dossier As String
    Dim FileItem As Scripting.File

    Dossier = "C:\00_Administratif\03_Offres"
    cible = NbSeparateur(Dossier)

    Suppcolonne

    'Appelle la procdure de recherche des fichiers
    ListeFichiers Dossier

    efface

    miseenforme

    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:F").AutoFit

 End Sub

Sub ListeFichiers(Repertoire As String)

    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim I As Long

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)

    'Nom des colonnes
    Cells(1, 1) = "Année"
    Cells(1, 2) = "N°"
    Cells(1, 3) = "Statut"
    Cells(1, 4) = "Nom de l'affaire"
    Cells(1, 5) = "Chemin Complet"
    Cells(1, 6) = "Date"

    'Récupère le numéro de la dernière ligne vide dans la colonne A.
    I = Range("A65536").End(xlUp).Row + 1

    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files

        'Inscrit le nom du fichier dans la cellule
        Cells(I, 1) = SourceFolder.Name

        'Nom du répertoire
        'Cells(I, 2) = Left(Nom, InStr("_", Nom))
        Cells(I, 2) = FileItem.Name

        'Nom du dossier
        Cells(I, 4) = FileItem.Name

        'Inscrit le nom du fichier dans la cellule
        Cells(I, 5) = FileItem.ParentFolder & "\" & FileItem.Name

        'Inscrit le nom du fichier dans la cellule
        Cells(I, 6) = FileItem.DateCreated

        I = I + 1
    Next FileItem

    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub
Sub miseenforme()

    Application.CutCopyMode = False
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$10"), , xlYes).Name = _
        "TableauOffre"
    Range("TableauOffre[#All]").Select
    ActiveSheet.ListObjects("TableauOffre").TableStyle = "ExportDonne_x"

End Sub
Sub Suppcolonne()
'
' Suppcolonne Macro
'

'
    Columns("A:F").Select
    Selection.ClearContents
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
End Sub
Sub efface()

Dim l As Integer

For l = Cells(65256, 1).End(xlUp).Row To 1 Step -1

If Cells(l, 1).Value = "03_Offres" Then Cells(l, 1).EntireRow.delete

Next l

End Sub

Function NbSeparateur(chemin As String) As Byte
    Dim m As Integer
    Dim Nb As Byte

    For m = 1 To Len(chemin)
        If Mid(chemin, m, 1) = "\" Then
            Nb = Nb + 1
            m = m + 1
        End If
    Next

    NbSeparateur = Nb
End Function

voila ce que ça donne comme résultat:

image

Mais je souhaiterais arriver à cela:

image

Je bloque donc sur plusieurs point....

- Mettre sous forme de tableau l'ensemble des données ( plage de données variable)

- Appliquer le remplissage du style du tableau (j'ai un remplissage en gris sur l'ensemble de la feuille)

- Dans le colonne B et D je souhaiterais avoir une partie du nom du fichier (en B: nom avant "_" et en D: nom après "_" sans l'extension)

Merci d'avance à ceux qui prendront le temps de répondre

Le 08/08/2021 à 21:58

Bonjour,

Voici un essai où j'ai enlevé ce qui ne me semblait pas nécessaire :

Option Explicit
public n&, t()

Sub Extraction()
dim tfiles
ListeFichiers "C:\00_Administratif\03_Offres"
tfiles = Filtre(application.transpose(t), "03_Offres", False)
n = 0: erase t
Raz
if isarray(tfiles) then Restitution tfiles
End Sub

Sub ListeFichiers(Repertoire As String)
dim fso as object, SourceFolder as object, Subfolder as object, FileItem as object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
For Each FileItem In SourceFolder.Files
    n = n + 1
    redim preserve t(1 to 6, 1 to n)
    t(1, n) = SourceFolder.Name
    t(2, n) = split(FileItem.Name, "_")(0)
    t(4, n) = split(split(FileItem.Name, "_")(1), ".")(0)
    t(5, n) = FileItem.path
    t(6, n) = FileItem.DateCreated
Next FileItem
For Each SubFolder In SourceFolder.SubFolders
    ListeFichiers SubFolder.Path
Next SubFolder
End Sub

function Filtre(ArrSrc, Critere$, optional Include as boolean = true, optional Col as byte = 1)
dim temp(), i&, j&, k&
For i = lbound(ArrSrc) to ubound(ArrSrc)
    If (ArrSrc(i, Col) like Critere) = Include Then
        j = j + 1: redim preserve temp(1 to ubound(ArrSrc, 2), 1 to j)
        for k = lbound(ArrSrc, 2) to ubound(ArrSrc, 2)
            temp(k, j) = ArrSrc(i, k)
        next k
    end if
Next i
if j > 0 then Filtre = application.transpose(temp)
End function

Sub Raz()
with ActiveSheet
    if .listobjects.count > 0 then .listobjects(1).delete
end with
end sub

Sub Restitution(tDatas)
with ActiveSheet
    .range("A1:F1").value = array("Année", "N°", "Statut", "Nom de l'affaire", "Chemin Complet", "Date")
    .cells(2, 1).resize(ubound(tDatas), ubound(tDatas, 2)).value = tDatas
    with .ListObjects.Add(xlSrcRange, .usedrange, , xlYes)
        .Name = "TableauOffre"
        .TableStyle = "ExportDonne_x"
        .columns.autofit
    end with
end with
End Sub

Je suis prêt à expliquer ce qui n'est pas clair.

Par ailleurs, je ne recommande pas le fond gris sur toute la feuille, ça n'a pour avantage que d'alourdir inutilement le fichier.

Cdlt,

Le 09/08/2021 à 11:32

merci pour le code mais quand je le lance cela bloque au niveau de la ligne de code ci-dessous:

 t(4, n) = split(split(FileItem.Name, "_")(1), ".")(0)
Le 09/08/2021 à 11:37

Bonjour,

Quel est le message ?

Est-ce que certains noms de fichier n'ont pas de "_" ? Si c'est le cas, que faut-il faire avec ces fichiers ?

Le 09/08/2021 à 19:44

Pour l'instant il n'y a que le fichier ou je crée ma liste qui n'a pas de "_" et qui se nomme "Liste des Offres" mais je suis entrain de réorganiser mon réseaux donc en condition réel il risque d'en avoir mais il ne me seras pas utile de les lister. Peut on envisager de ne lister que les fichiers avec "_" ?

voila l'erreur

image
Le 09/08/2021 à 21:15

D'accord, dans ce cas, voici un nouvel essai sans les fichiers qui ne contiennent pas "_" :

Option Explicit
public n&, t()

Sub Extraction()
dim tfiles
ListeFichiers "C:\00_Administratif\03_Offres"
tfiles = Filtre(application.transpose(t), "03_Offres", False)
n = 0: erase t
Raz
if isarray(tfiles) then Restitution tfiles
End Sub

Sub ListeFichiers(Repertoire As String)
dim fso as object, SourceFolder as object, Subfolder as object, FileItem as object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
For Each FileItem In SourceFolder.Files
    if fileitem.name like "*_*" then
        n = n + 1
        redim preserve t(1 to 6, 1 to n)
        t(1, n) = SourceFolder.Name
        t(2, n) = split(FileItem.Name, "_")(0)
        t(4, n) = split(split(FileItem.Name, "_")(1), ".")(0)
        t(5, n) = FileItem.path
        t(6, n) = FileItem.DateCreated
    end if
Next FileItem
For Each SubFolder In SourceFolder.SubFolders
    ListeFichiers SubFolder.Path
Next SubFolder
End Sub

function Filtre(ArrSrc, Critere$, optional Include as boolean = true, optional Col as byte = 1)
dim temp(), i&, j&, k&
For i = lbound(ArrSrc) to ubound(ArrSrc)
    If (ArrSrc(i, Col) like Critere) = Include Then
        j = j + 1: redim preserve temp(1 to ubound(ArrSrc, 2), 1 to j)
        for k = lbound(ArrSrc, 2) to ubound(ArrSrc, 2)
            temp(k, j) = ArrSrc(i, k)
        next k
    end if
Next i
if j > 0 then Filtre = application.transpose(temp)
End function

Sub Raz()
with ActiveSheet
    if .listobjects.count > 0 then .listobjects(1).delete
end with
end sub

Sub Restitution(tDatas)
with ActiveSheet
    .range("A1:F1").value = array("Année", "N°", "Statut", "Nom de l'affaire", "Chemin Complet", "Date")
    .cells(2, 1).resize(ubound(tDatas), ubound(tDatas, 2)).value = tDatas
    with .ListObjects.Add(xlSrcRange, .usedrange, , xlYes)
        .Name = "TableauOffre"
        .TableStyle = "ExportDonne_x"
        .columns.autofit
    end with
end with
End Sub

Cdlt,

Le 11/08/2021 à 23:37

J'ai essayé ton 2ème code mais l'erreur été toujours la j'ai pu contourner le problème en le faisant en 2 fois. Après ton code n'afficher plus d'erreur mais pas de résultat n'on plus.... (je l'ai testé en plusieurs fois donc possible que j'ai touché quelque chose).

Du coup comme je comprenais pas tous à ton code (je débute) j'ai fais un mixte avec le mien et j'ai pu aboutir au résultat escompter!

Je pense que l'on peut optimiser mon code mais je le ferais quand j'aurais de meilleur connaissance (la comprend presque tous) et pour la mise en forme je verrais plus tard!

Donc Problème résolu!!

Merci d'avoir pris le temps de m'aider

Option Explicit

Sub Extraction()
Dim Dossier As String
Dim FileItem As Scripting.File

Dossier = "C:\00_Administratif\03_Offres"

Suppcolonne

ListeFichiers Dossier

efface

miseenforme

Columns("A:F").AutoFit

End Sub

Sub ListeFichiers(Repertoire As String)

Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim Subfolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim i As Long
Dim Nom As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(Repertoire)

Cells(1, 1) = "Dossier"
Cells(1, 2) = "N°de l'affaire"
Cells(1, 3) = "Nom de l'affaire"
Cells(1, 4) = "Chemin Complet"
Cells(1, 5) = "Date"
Cells(1, 6) = "Vérif. Statut"

i = Range("A65536").End(xlUp).Row + 1

For Each FileItem In SourceFolder.Files
Nom = Split(FileItem.Name, ".")(0)
    If FileItem.Name Like "*_*" Then
        Cells(i, 1) = SourceFolder.Name
        Cells(i, 2) = Split(FileItem.Name, "_")(0)
        Cells(i, 3) = Split(Nom, "_")(1)
        Cells(i, 4) = FileItem.Path
        Cells(i, 5) = FileItem.DateCreated
        i = i + 1
        End If
Next FileItem
For Each Subfolder In SourceFolder.SubFolders
    ListeFichiers Subfolder.Path
Next Subfolder

End Sub
Sub miseenforme()
    With ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Offset(1, 5)), xlYes)
        .Name = "TableauOffre"
        .TableStyle = "ExportDonne_x"
    End With
End Sub
Sub Suppcolonne()
    Columns("A:F").Select
    Selection.ClearContents
End Sub
Sub efface()

Dim l As Integer

For l = Cells(65256, 1).End(xlUp).Row To 1 Step -1

If Cells(l, 1).Value = "03_Offres" Then Cells(l, 1).EntireRow.delete

Next l

End Sub
Le 12/08/2021 à 00:24

Bonsoir Excelium,

Merci du retour !

Je viens de modifier mon dernier code dans lequel il y avait une petite erreur. Peux-tu quand même l'essayer ?

Cdlt,

Le 12/08/2021 à 01:00

Oui pas de problème post ton code et je ferais le test

Le 12/08/2021 à 08:14

Ca y est, j'ai modifié le code de mon commentaire de lundi à 21h15.

Le 14/08/2021 à 10:56

j'ai réessayé et a la fin de t'as Function il faut mettre End Function mais après avoir corrigé cela plus d'erreur mais ne ce passe toujours rien

Le 14/08/2021 à 13:21

J'ai à nouveau modifié le code. Le souci venait de la fonction Filtre . Je pense (et j'espère) que ça ira mieux maintenant.

Au cas où, pour mieux tester du code et progresser, il faut savoir qu'il est possible d'exécuter au pas à pas détaillé à l'aide de la touche F8 du clavier. Il est également possible de marquer des points d'arrêt sur certaines lignes importantes (en cliquant dans la marge juste à côté >>> un point marron apparait) afin d'inspecter le déroulement de l'exécution à un endroit précis.

Cdlt,

Le 14/08/2021 à 19:34

Merci pour l'astuce, j'ai refais le test et il y avais encore une erreur que j'ai corrigé au niveau de l'ajustement des colonnes et maintenant le code fonctionne et il est plus rapide que le mien rien que sur quelque fichier!

Par contre entre temps j'ai rajouter des fichiers excel et pdf dans le dossier et le format date ne s'applique pas il les écrit sous forme de texte car même manuellement via le format de cellule après avoir lancé la macro cela ne change pas peux tu m'indiquer pourquoi?

image 
Option Explicit
Public n&, t()

Sub Extraction()
Dim tfiles
ListeFichiers "C:\00_Administratif\03_Offres"
tfiles = Filtre(Application.Transpose(t), "03_Offres", False)
n = 0: Erase t
Raz
If IsArray(tfiles) Then Restitution tfiles
End Sub

Sub ListeFichiers(Repertoire As String)
Dim fso As Object, SourceFolder As Object, Subfolder As Object, FileItem As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(Repertoire)
For Each FileItem In SourceFolder.Files
    If FileItem.Name Like "*_*" Then
        n = n + 1
        ReDim Preserve t(1 To 6, 1 To n)
        t(1, n) = SourceFolder.Name
        t(2, n) = Split(FileItem.Name, "_")(0)
        t(4, n) = Split(Split(FileItem.Name, "_")(1), ".")(0)
        t(5, n) = FileItem.Path
        t(6, n) = FileItem.DateCreated
    End If
Next FileItem
For Each Subfolder In SourceFolder.SubFolders
    ListeFichiers Subfolder.Path
Next Subfolder
End Sub

Function Filtre(ArrSrc, Critere$, Optional Include As Boolean = True, Optional Col As Byte = 1)
Dim temp(), i&, j&, k&
For i = LBound(ArrSrc) To UBound(ArrSrc)
    If (ArrSrc(i, Col) Like Critere) = Include Then
        j = j + 1: ReDim Preserve temp(1 To UBound(ArrSrc, 2), 1 To j)
        For k = LBound(ArrSrc, 2) To UBound(ArrSrc, 2)
            temp(k, j) = ArrSrc(i, k)
        Next k
    End If
Next i
If j > 0 Then Filtre = Application.Transpose(temp)
End Function

Sub Raz()
With ActiveSheet
    If .ListObjects.Count > 0 Then .ListObjects(1).delete
End With
End Sub

Sub Restitution(tDatas)
With ActiveSheet
    .Range("A1:F1").Value = Array("Année", "N°", "Statut", "Nom de l'affaire", "Chemin Complet", "Date")
    .Cells(2, 1).Resize(UBound(tDatas), UBound(tDatas, 2)).Value = tDatas
    .Columns.AutoFit
    With .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes)
        .Name = "TableauOffre"
        .TableStyle = "ExportDonne_x"
    End With
End With
End Sub
Le 14/08/2021 à 20:37

Je suis content que ça marche enfin.

Non, je n'ai pas vraiment d'idée de la raison de cette différence entre les fichiers word et les autres...

Peux-tu essayer de modifier cette ligne dans la macro ListeFichiers :

t(6, n) = cDate(FileItem.DateCreated)

Si ça ne marche pas, je regarderai de plus près.

Rechercher des sujets similaires à "vba liste fichier mise forme tableau nom partiel"