LIster noms de fichiers dans une plage verticale/horizontale

Bonjour,

Malgré les différents thread consultés sur des sujets connexes, je n'arrive pas à mes fins.

J'ai mis 3 fichiers xlsx vierges nommés "truc", "machin" et "chose" dans un dossier commun, et je cherche depuis mon fichier Test.xlsm (placé dans le même dossier) à afficher les noms de fichier de la façon suivante :

la boucle While ouvrant les fichiers par ordre alphabétique (si je ne dis pas de bêtises), j'aimerais écrire le nom du dernier fichier sur une nouvelle colonne

Option Explicit
Sub RecupNom()

Dim Chemin As String, Fichier As String

    Chemin = "\\chemin\Desktop\DOSSIERTEST"

    ChDir Chemin

    Fichier = Dir(Chemin & "\*.xlsx")

        While Len(Fichier) > 0
            Workbooks.Open Fichier
            Workbooks("Test.xlsm").Activate
            Range("A" & ActiveSheet.UsedRange.Rows.Count + 2 & ":A" & ActiveSheet.UsedRange.Rows.Count) = Fichier
            Workbooks(Fichier).Close
            Fichier = Dir
        Wend

End Sub

A l'aide du code ci-dessus, j'arrive au mieux à récupérer le nom de chaque fichier 2-3 fois d'affilé et uniquement sur la colonne A

Une idée de la marche à suivre ?

Merci d'avance

Bonjour,

s'il s'agit juste de récupérer le nom, pas besoin d'ouvrir les classeurs.

un essai "tout dans la même colonne"

Sub RecupNom()
Dim Chemin As String, Fichier As String

    Chemin = "\\chemin\Desktop\DOSSIERTEST"
    'ChDir Chemin
    Fichier = Dir(Chemin & "\*.xlsx")
    Do While Fichier <> ""       
            x = x + 1
            Range("A" & x) = Fichier
            Fichier = Dir
    Loop
End Sub

Un essai avec le dernier fichier lu en colonne B. Comme on ne sait pas au départ combien on aura de fichier, on ne sait pas quel est le dernier . Donc, on copie tous les fichiers dans un tableau en mémoire, puis on copie ce tableau sauf la dernière ligne en colonne A, et on copie la dernière ligne du tableau en colonne B:

Sub RecupNom()
Dim Chemin As String, Fichier As String, T()

    Chemin = "\\chemin\Desktop\DOSSIERTEST"
    'ChDir Chemin
    Fichier = Dir(Chemin & "\*.xlsx")
    Do While Fichier <> ""        'on remplit le tableau
            x = x + 1
            ReDim Preserve T(1 To x)
            T(x) = Fichier
            Fichier = Dir
    Loop
    Range("A1").Resize(UBound(T) - 1, 1) = Application.Transpose(T) 'on copie sauf la dernière
    Range("B1") = T(UBound(T))            'on copie la dernière
End Sub

A+

Bonjour et merci AlgoPlus,

Testé ce matin et fonctionnel ! Je vais pouvoir m'inspirer de ton code pour lister une trentaine de fichiers

Cdlt

En fait je cherchais plutôt à faire quelque chose de la sorte, à la seule différence que les noms de fichiers seront sélectionnés automatiquement + destination prédéfinie

Option Explicit

Sub Test2()

Dim Tbl() As String
    Dim I As Integer

    Tbl = EnumFichiers("\\RCDESK02\MBILLIEU\Desktop\DOSSIERTEST")

    'en colonne "A" et "B" de la feuille active si pas vide
    If Not (Not Tbl) Then

        For I = 1 To UBound(Tbl)

            Cells(I, 1) = Tbl(I)
           ' Cells(I, 2) = Right(Tbl(I), Len(Tbl(I)) - InStrRev(Tbl(I), ".")) 'pas utile pour mon cas

        Next I

    End If

Dim xLRow As Long
Dim xNRow As Long
Dim I1 As Long
Dim xUpdate As Boolean
Dim xRg As Range
Dim xOutRg As Range
Dim xTxt As String

On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select data range(only one column):", "Kutools for Excel", xTxt, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
    If (xRg.Columns.Count > 1) Or _
       (xRg.Areas.Count > 1) Then
        MsgBox "the used range only contain one column", , "Kutools for Excel"
        Exit Sub
    End If
    Set xOutRg = Application.InputBox("please select output range(specify one cell):", "Kutools for Excel", xTxt, , , , , 8)
    If xOutRg Is Nothing Then Exit Sub
    Set xOutRg = xOutRg.Range(1)

    xLRow = xRg.Rows.Count
    For I1 = 1 To xLRow Step 6
        xRg.Cells(I1).Resize(6).Copy
        xOutRg.Offset(xNRow, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        xNRow = xNRow + 1
    Next

End Sub
________________________________________________________________________
Function EnumFichiers(Chemin As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    'complète le chemin le cas échéant
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'récupère les fichiers
    Fichier = Dir(Chemin)

    'boucle sur les fichiers du dossier
    Do While (Len(Fichier) > 0)

        I = I + 1

        ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Fichier

        Fichier = Dir()

    Loop

    'retourne le tableau des noms de fichiers
    EnumFichiers = TableauFichiers()

End Function

Je ne vais pas m'amuser à décrypter le code pour comprendre ce que vous envisagez de modifier ....

De plus, il est préférable, pour avoir plus de chance d'avoir des réponses, d'exposer le nouveau souci dans un nouveau post.

Bonne suite

Je ne nécessite pas d'aide supplémentaire, désolé si mon message portait à confusion

Je résoudrai ce thread lorsque j'aurais édité le code pour réaliser ce que je souhaite en le postant ici

Bien à vous