VBA列出具有特定單詞（excel）的專案（包括檔案夾）

我想問一下VBA是否有辦法用OLDIES列出所有檔案（包括檔案夾/子檔案夾）-（無論這里的文本或數字是什么）

Sub ListOLDIES()
Dim FSO As Object, FSOSubFolder As Object, FileName As String
Dim FSOFile As Object, objFolder As Object, RowNum As Integer
Dim ExtSplit As Variant, NameSplit As Variant
strDirectory = "C:\Desktop\"
RowNum = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strDirectory)
For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

For Each FSOFile In objFolder.Files
If InStr(FSOFile.path, "OLDIES") Then
ExtSplit = Split(FSOFile.path, ".")
NameSplit = Split(FSOFile.path, "\")
FileName = Left(NameSplit(UBound(NameSplit)), _
           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
Flpath = Left(FSOFile.path, Len(FSOFile.path) - Len(NameSplit(UBound(NameSplit))))
ActiveSheet.Cells(RowNum, 1) = FileName & ", " & Flpath & ", ." & ExtSplit(UBound(ExtSplit))
RowNum = RowNum   1
End If
Next FSOFile
Set objFolder = Nothing
Set FSO = Nothing
End Sub

使用該代碼時出現“堆疊空間不足”錯誤。

期望的結果；

謝謝！

uj5u.com熱心網友回復：

問題是您遞回地運行您的程式

For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

但是因為您將啟動檔案夾設定為strDirectory = "C:\Desktop\"每次運行該程式時它都會開始無限運行C:\Desktop\并且永遠不會進入子檔案夾。

如果您將 aDebug.Print放入該回圈

For Each FSOSubFolder In objFolder.subfolders
    Debug.Print FSOSubFolder.Path
    ListOLDIES
Next FSOSubFolder

你會看到它總是列印第一個子檔案夾并且從不進入它。當您使用 F8 逐步運行代碼時，您可以看到最好的效果。

如何解決這個問題？

因此，您需要做的是，strDirectory當您再次遞回啟動您的程式時，您需要將啟動檔案夾設定為子檔案夾ListOLDIES。因此，我們需要洗掉strDirectory = "C:\Desktop\"添加它作為引數。

Sub ListOLDIES(ByVal strDirectory As String)

并將遞回呼叫更改為ListOLDIES FSOSubFolder.Path

如果我們現在使用

Option Explicit

Public Sub Example()
    ListOLDIES "C:\Desktop"
End Sub

Public Sub ListOLDIES(ByVal strDirectory As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim objFolder As Object
    Set objFolder = FSO.GetFolder(strDirectory)
    
    Dim FSOSubFolder As Object
    For Each FSOSubFolder In objFolder.subfolders
        Debug.Print FSOSubFolder.Path
        ListOLDIES FSOSubFolder.Path
    Next FSOSubFolder
    
    Dim FSOFile As Object
    For Each FSOFile In objFolder.Files
        Debug.Print FSOFile.Path
    Next FSOFile
    
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub

我們得到所有（子）檔案夾和檔案的串列"C:\Desktop"。

我使用了如下測驗設定：

C:\Desktop\Sub Folder 1
C:\Desktop\Sub Folder 2
C:\Desktop\Sub Folder 2\OLDIES-12345
C:\Desktop\Sub Folder 2\OLDIES-23456
C:\Desktop\Sub Folder 2\OLDIES-23456\OLDIES-12345.zip
C:\Desktop\Sub Folder 2\OLDIES-23456\OLDIES-23456.xml
C:\Desktop\Sub Folder 3
C:\Desktop\Sub Folder 3\OLDIES-12345.txt
C:\Desktop\Sub Folder 3\OLDIES-23456.txt

要保持對RowNum整個遞回呼叫的計數，您需要將該變數設為Static。如果您希望能夠重置它，請添加一個引數：

Option Explicit

Public Sub Example()
    ListOLDIES "C:\Desktop", True
End Sub

Public Sub ListOLDIES(ByVal strDirectory As String, Optional ByVal ResetRowNum As Boolean = False)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim objFolder As Object
    Set objFolder = FSO.GetFolder(strDirectory)
    
    Static RowNum As Long
    If ResetRowNum Then RowNum = 1
    
    Dim ws As Worksheet ' output sheet
    Set ws = ActiveSheet ' better use something like ThisWorkbook.Worksheets("Sheet1") to define a specific sheet name
    
    Dim FSOSubFolder As Object
    For Each FSOSubFolder In objFolder.subfolders
        InStr(1, FSOSubFolder.Name, "OLDIES", vbTextCompare)
            ' output folders with OLDIES
            ws.Cells(RowNum, 1).Value = FSOSubFolder.Name
            ws.Cells(RowNum, 2).Value = FSOSubFolder.ParentFolder.Path & "\"
            ws.Cells(RowNum, 3).Value = "Folder"
            RowNum = RowNum   1
        End If
        ListOLDIES FSOSubFolder.Path
    Next FSOSubFolder
    
    Dim FSOFile As Object
    For Each FSOFile In objFolder.Files
        If InStr(1, FSOFile.Name, "OLDIES", vbTextCompare) Then
            ' output files with OLDIES
            ws.Cells(RowNum, 1).Value = FSO.getBaseName(FSOFile)
            ws.Cells(RowNum, 2).Value = FSOFile.ParentFolder.Path & "\"
            ws.Cells(RowNum, 3).Value = "." & FSO.getExtensionName(FSOFile)
            RowNum = RowNum   1
        End If
    Next FSOFile
    
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub

所以我的測驗設定的輸出將是：

uj5u.com熱心網友回復：

這應該作業：

Sub list_oldies()
    Dim FileSystem As Object
    Dim HostFolder As String
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    HostFolder = "C:\Users\salzerm.kontura\Desktop\Test\"
        
    DoFolder FileSystem.GetFolder(HostFolder), 1
End Sub
    
Sub DoFolder(folder, RowNum As Integer)
    Dim SubFolder
    Dim ExtSplit As Variant
    Dim NameSplit As Variant
    
    For Each SubFolder In folder.SubFolders
        If InStr(SubFolder, "Oldies") Then
                ExtSplit = "Folder"
                NameSplit = Split(SubFolder, "\")
                Filename = Left(NameSplit(UBound(NameSplit)), _
                           Len(NameSplit(UBound(NameSplit))) - 1)
                Flpath = Left(SubFolder, Len(SubFolder) - Len(NameSplit(UBound(NameSplit))))
                ActiveSheet.Cells(RowNum, 1) = Filename
                ActiveSheet.Cells(RowNum, 2) = Flpath
                ActiveSheet.Cells(RowNum, 3) = ExtSplit
                RowNum = RowNum   1
        End If
        
        DoFolder SubFolder, RowNum
    Next
    Dim file
    For Each file In folder.Files
        If file Like "*Oldies*.*" Then
                ExtSplit = Split(file, ".")
                NameSplit = Split(file, "\")
                Filename = Left(NameSplit(UBound(NameSplit)), _
                           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
                Flpath = Left(file, Len(file) - Len(NameSplit(UBound(NameSplit))))
                ActiveSheet.Cells(RowNum, 1) = Filename
                ActiveSheet.Cells(RowNum, 2) = Flpath
                ActiveSheet.Cells(RowNum, 3) = ExtSplit(UBound(ExtSplit))
                RowNum = RowNum   1
        End If
    Next
End Sub

uj5u.com熱心網友回復：

請嘗試下一個代碼。它速度更快，更緊湊，并回傳您需要的所有內容，以及初始回傳的陣列（在 D:D 列中）：

Sub list_oldies()
   Dim arrFoldFiles, strPath As String, strSearch As String
   Dim strExt As String, arrFin, i As Long, arrName, arrExt
   
   strSearch = "Oldies"
   strExt = "*" & strSearch & "*.*"
   strPath = "C:\Desktop\"
   
   arrFoldFiles = filter(Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strPath & strExt & """ /b/s").StdOut.ReadAll, vbCrLf), "\")
    ReDim arrFin(1 To UBound(arrFoldFiles)   1, 1 To 3)
    For i = 0 To UBound(arrFoldFiles)
        arrName = Split(arrFoldFiles(i), "\")
        arrExt = Split(arrName(UBound(arrName)), ".")
            arrFin(i   1, 1) = arrExt(0)
        If UBound(arrExt) > 0 Then
             arrFin(i   1, 3) = arrExt(1)
        Else
            arrFin(i   1, 3) = "Folder"
        End If
        arrFin(i   1, 2) = left(arrFoldFiles(i), InStrRev(arrFoldFiles(i), "\"))
    Next i
    'drop the arrays content:
    Range("A1:D1").value = Array("Name", "Location", "Extension", "All")
    Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
    Range("D2").Resize(UBound(arrFoldFiles)   1, 1).value = Application.Transpose(arrFoldFiles)
    Range("A1:D1").EntireColumn.AutoFit
End Sub

標籤：擅长 vba

上一篇：CATIA使用DXF轉換生成文本。規模問題

下一篇：如何將表格粘貼到我的第一頁/部分？