Nom du fichier et chemin d'accès dans la feuille de calcul pour le nombre de dires et de caractères spécifiques

Question

J'ai essayé et recherché dans le forum vba comment trouver le code (ci-dessous) pour rechercher des fichiers dans un répertoire spécifique et ses sous-répertoires pour lister et peupler la liste de fichiers qui ont 20 caractères dans la longueur du nom de fichier et seulement seulement l'extension pdf.

Je veux la liste de fichiers sans extension à la fin dans la colonne A et le chemin complet du fichier et le nom dans la colonne B.

également essayé de trier tous les fichiers croissant après la liste créée, mais pas encore le succès :( toute aide Merci

Sub ListPDF() 

Range("A:L").ClearContents 
Range("A1").Select 

Dim strPath As String 
strPath = "K:\Test\PDF\" 
Dim OBJ As Object, Folder As Object, File As Object 
Set OBJ = CreateObject("Scripting.FileSystemObject") 
Set Folder = OBJ.GetFolder(strPath) 
Call ListFiles(Folder) 
Dim SubFolder As Object 
For Each SubFolder In Folder.Subfolders 
    Call ListFiles(SubFolder) 
    Call GetSubFolders(SubFolder) 
Next SubFolder 
Range("A1").Select 
End Sub 

Sub ListFiles(ByRef Folder As Object) 
For Each File In Folder.Files 
     ActiveCell.Offset(1, 0).Select 
     ActiveCell.Offset(0, 0) = File.Name 
     ActiveCell.Offset(0, 1) = File.Path 
Next File 
End Sub 

Sub GetSubFolders(ByRef SubFolder As Object) 
    Dim FolderItem As Object 
    For Each FolderItem In SubFolder.Subfolders 
    Call ListFiles(FolderItem) 
    Call GetSubFolders(FolderItem) 
Next FolderItem 
End Sub 

Answer 1

Utilisez ceci:

---

Option Explicit 

Dim fso As Object, fsoFolder As Object, fsoSubFolder As Object, fsoFile As Object 

Public Sub ListPDFs() 
    Dim ws As Worksheet 

    Set ws = ThisWorkbook.Worksheets("Sheet1") 

    ws.UsedRange.ClearContents 

    Set fso = CreateObject("Scripting.FileSystemObject") 

    Application.ScreenUpdating = False 

     ShowPDFs ThisWorkbook.Path & "\..", ws 

     ws.UsedRange.EntireColumn.AutoFit 

    Application.ScreenUpdating = True 

End Sub 

---

Public Sub ShowPDFs(ByRef fsoPath As String, ByRef ws As Worksheet) 
    Dim lastCell As Range, pdfName As String 

    Set fsoFolder = fso.GetFolder(fsoPath) 

    For Each fsoFile In fsoFolder.Files 

     pdfName = fsoFile.Name 

     If Len(pdfName) > 20 Then 
      If InStr(1, pdfName, ".pdf") > 0 Then 

       pdfName = Left(pdfName, InStrRev(pdfName, ".") - 1) 
       Set lastCell = ws.Cells(ws.Rows.Count, 1).End(xlUp) 

       lastCell.Offset(1, 0) = pdfName 
       lastCell.Offset(1, 1) = fsoFile.Path 
      End If 
     End If 
    Next 

    For Each fsoSubFolder In fsoFolder.SubFolders 
     ShowPDFs fsoSubFolder.Path, ws 
    Next 
End Sub