List files name and path in worksheet for specific

问题:

I've tried and search through out vba forum to figure out how can I rectify my code (below) to search files within a specific directory and its sub-directories to list and populated list of file that have 20 characters in filename length and just only pdf extension.

I want to list of file with no extension at the end in column A and full file path and name in column B.

Also tried to sort all files ascending after list created but no success yet :( any help? Thanks

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

回答1:

Use this:

---

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