logo标签列表

在多个子文件夹中搜索文件的VBA宏

vbaexcel
8

我有一个宏，如果我在单元格E1中输入文件名，宏会搜索C:\Users\Marek\Desktop\Makro\目录中的文件，并将所需值放入我的原始文件中的特定单元格中。

是否可能使其在没有特定文件夹位置的情况下工作？我需要能够搜索C:\Users\Marek\Desktop\Makro\及其许多子文件夹。

我的代码：

Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath    'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text

If FName = False Then
    'do nothing
Else
    GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False

        End If

  ChDrive SaveDriveDir
  ChDir SaveDriveDir
End Sub
4个回答
26

仅供娱乐，以下是一个使用递归函数的示例，我希望这个示例应该更简单易懂，并可以与你的代码一起使用：

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set myFolder = FSO.GetFolder(sPath)
    For Each mySubFolder In myFolder.SubFolders
        Call TestSub(mySubFolder.Path)
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub

Sub TestSub(ByVal s As String)

    Debug.Print s

End Sub

编辑：以下是如何在您的工作簿中实现此代码以达到您的目标。

Sub TestSub(ByVal s As String)

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(s)
    For Each myFile In myFolder.Files
        If myFile.Name = Range("E1").Value Then
            Debug.Print myFile.Name 'Or do whatever you want with the file
        End If
    Next

End Sub

在这里，我只是调试了找到的文件名称，其余部分由您决定。 ;)

当然，有些人会说两次调用FileSystemObject有点笨拙，所以您可以像这样编写代码（取决于您是否想要进行分隔）：

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(sPath)

    For Each mySubFolder In myFolder.SubFolders
        For Each myFile In mySubFolder.Files
            If myFile.Name = Range("E1").Value Then
                Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
                Exit For
            End If
        Next
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub
谢谢，我认为这正是我正在寻找的。你确定这段代码是正确的吗？因为在我的立即窗口中，我没有从Debug.Print得到任何响应。 - trenccan
如果您的子文件夹中有一个文件与E1中的名称匹配，它将仅调试文件名（因此请确保首先验证条件）。如果您想在调试窗口中查看所有文件，请注释条件行（即“if”和“end if”以及“exit for”）。 - Tete1805
请问我如何改进这段代码：对于每个mySubFolder.Files中的myFile， 如果myFile.Name = Sheets("Sheet1").Range("O5").Value & ".xlsx"，那么......如果我还想找到具有xls扩展名的文件。更好地说，我想找到名称与我放在O5范围内的文件，无论是xls还是xlsx都可以。谢谢！ - trenccan
1
@trenccan 抱歉，伙计，我最近没有查看这个线程。你尝试过研究InStr()函数吗？就像 If InStr(1, myFile.Name, Sheets("Sheet1").Range("O5").Value) Then... - Tete1805
6
这个子程序将使用您传递的文件名或模式填充一个集合，该集合包含所有匹配的文件。
Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s
    
    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
    
    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop
    
    If DoSubfolders then
        sf = Dir(StartFolder, vbDirectory)
        Do While Len(sf) > 0
            If sf <> "." And sf <> ".." Then
                If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                        subF.Add StartFolder & sf
                End If
            End If
            sf = Dir()
        Loop
    
        For Each s In subF
            GetFiles CStr(s), Pattern, True, colFiles
        Next s
    End If

End Sub

使用方法：

Dim colFiles As New Collection

GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
    'work with found files
End If
我曾经为自己使用过这个，现在我正试图找出如何在文件夹/子文件夹中没有找到文件的情况下更改单元格颜色。它的工作表现完美无缺，除了这个问题。如果您可以帮忙，那就太棒了。我会在这里链接我的问题。[https://stackoverflow.com/questions/62918340/changing-cell-color-while-adding-items-to-a-collection] - JoshL
3
如果有帮助的话，你还可以使用 FileSystemObject 来检索文件夹的所有子文件夹。你需要检查 "Microsot Scripting Runtime" 引用以获取 Intellisense 并使用 "new" 关键字。
Sub GetSubFolders()

    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder

    Set f = fso.GetFolder("D:\Proj\")
    For Each sf In f.SubFolders
        'Code inside
    Next

End Sub
2

我今天刚发现了这个，正好是我正在处理的一个问题。它可以返回文件夹及其子文件夹中所有文件的文件路径。

Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant

For Each vFile In colFiles
     'file operation here or store file name/path in a string array for use later in the script
     filepath(n) = vFile
     filename = fso.GetFileName(vFile) 'If you want the filename without full path
     n=n+1
Next vFile


'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
Loop
If bIncludeSubfolders Then

    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
        If (strTemp <> ".") And (strTemp <> "..") Then
            If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                colFolders.Add strTemp
            End If
        End If
        strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
        Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
End If
End Function

Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
        TrailingSlash = strFolder
    Else
        TrailingSlash = strFolder & "\"
    End If
End If
End Function

这是根据Ammara Digital Image Solutions的一篇文章进行改编的。(http://www.ammara.com/access_image_faq/recursive_folder_search.html)。
你需要设置哪些引用来进行早期绑定这些东西？ - Daniel L. VanDenBosch
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接