excel - 这是选择性循环 excel vba 中目录的最佳方法(如果有的话)

Question

IO想要检查路径主目录/ABC*/Y/XY*/*.edf下的所有edf文件，然后检查文件中是否有特定短语，如果找到则检查另一个短语等，然后填写电子表格中的数据。我尝试通过三种方法来实现这一目标，但每种方法都在某些时候陷入困境。你们中的任何人都可以通过代码并告诉我哪里错了以及哪种方法是最好的(如果有的话)。由于我之前的问题造成了误解，我不希望任何人为我编写代码。我已经开始学习 vba 三天了，我有 5 天的时间来完成这个项目。这就是为什么如果有人能看一下并告诉我哪里出错了，我将不胜感激。

通过简单目录命令的方法1在此，FCS* 的第一个循环工作得很好，但第二个循环根本不起作用，并在第一次迭代时给出运行时错误。我知道这不是一个好方法，但以防万一其他方法不起作用。

 Sub Iterate_Folders()
        Dim ctr As Integer
        Dim ctr1 As Integer
        ctr = 1
        ctr1 = 1
        Paths = "C:\Users\sobiakanwal\Downloads\QSHWRA\QSHWRA\ "   ' Path should always contain a '\' at end
        FirstDir = Dir(Paths, vbDirectory)   ' Retrieving the first entry.
        Do Until FirstDir = ""   ' Start the loop.
            If (FirstDir Like "FCS*") Then
                ActiveSheet.Cells(ctr, 15).Value = Paths & FirstDir
                Path1 = Paths & FirstDir & "\FUNCTION_BLOCK\DR*"
                ActiveSheet.Cells(ctr, 20).Value = Path1
                'ActiveSheet.Cells(ctr, 25).Value = SecondDir
                SecondDir = Dir(Path1, vbDirectory)
                Do While SecondDir = ""
                    ActiveSheet.Cells(ctr, 30).Value = "Hi"
                    If (True) Then
                        ctr1 = ctr1 + 1
                    End If
                    SecondDir = Dir()
                Loop
                ctr = ctr + 1
            Else

            End If
            FirstDir = Dir()   ' Getting next entry.
        Loop
        MsgBox (ctr1)
    End Sub

通过递归的方法 2我在教程中找到了这方面的基本代码，然后根据我的优势对其进行了一些编辑。这通常不起作用，但以某种硬编码的方式给出了正确的答案。但我希望你检查一下我陷入递归函数的地方，我需要在其中添加文件处理代码。

Public temp() As String
Public Count As Integer
Function ListFiles(FolderPath As String)

    Dim myFile As String, text As String, textline As String, posLat As Integer, posLong As Integer
    Dim k As Long, i As Long
    ReDim temp(2, 0)
    Count = 1
    If Right(FolderPath, 1) <> "\" Then
        FolderPath = FolderPath & "\"
    End If
    Recursive FolderPath
    k = Range(Application.Caller.Address).Rows.Count
    If k < UBound(temp, 2) Then
        MsgBox "There are more rows, extend user defined function"
    Else
        For i = UBound(temp, 2) To k
              ReDim Preserve temp(UBound(temp, 1), i)
                temp(0, i) = ""
                temp(1, i) = ""
                temp(2, i) = ""
        Next i
    End If
    ListFiles = Application.Transpose(temp)
    ReDim temp(0)

End Function



Function Recursive(FolderPath As String)

    Dim strFilename As String
    Dim strFileContent As String
    Dim iFile As Integer
    Dim fileName As String, textData As String, textRow As String, fileNo As Integer
    Dim Value As String, Folders() As String
    Dim Folder As Variant, a As Long
    Dim Right_FolderPath As String
    ReDim Folders(0)
    If Right(FolderPath, 2) = "\\" Then Exit Function
    Value = Dir(FolderPath, &H10)
    Do Until Value = ""
        If Value = "." Or Value = ".." Then
        Else
            If GetAttr(FolderPath & Value) = 16 Then
                Folders(UBound(Folders)) = Value
                ReDim Preserve Folders(UBound(Folders) + 1)
            Else
                If Right(Value, 4) = ".edf" Then
                If Count = 4 Then
                    Right_FolderPath = Right(FolderPath, 7)
                    If Left(Right_FolderPath, 2) = "DR" Then
                        strFilename = FolderPath & Value
                        iFile = FreeFile
                        Open strFilename For Input As #iFile
                        strFileContent = Input(LOF(iFile), iFile)
                        Close #iFile

                         If InStr(1, strFileContent, "hihowareyou") <> 0 Then
                            ActiveSheet.Cells(1, 1) = strFilename
                            longLoc = InStr(1, strFileContent, "Longitude:")
                            If longLoc <> 0 Then
                                 ActiveSheet.Cells(1, 2) = Mid(strFleContent, longLoc + Len("Longitude:"), 10)
                            End If
                        End If

                ''''Here it goes all wrong

                    'myFile = FolderPath & Value
                    'myFile = Application.GetOpenFilename()
                    'fileNo = FreeFile 'Get first free file number
                    'Open fileName For Input As #fileNo
                    'Do While Not EOF(fileNo)
                    '    Line Input #fileNo, textRow
                    '    textData = textData & textRow
                    'Loop
                    'Close #fileNo
                    'posLat = InStr(text, "ff-ai")
                    'If Not posLat = vbNullString Then
                    '    temp(0, UBound(temp, 2)) = Value
                    'End If
                        temp(0, UBound(temp, 2)) = FolderPath
                        temp(1, UBound(temp, 2)) = Value
                        temp(2, UBound(temp, 2)) = Count ' FileLen(FolderPath & Value)
                        ReDim Preserve temp(UBound(temp, 1), UBound(temp, 2) + 1)
                    End If
                End If
            End If
            End If
        End If
        Value = Dir
    Loop

    For Each Folder In Folders
        Count = Count + 1
        Recursive FolderPath & Folder & "\"
        Count = Count - 1
    Next Folder

End Function

字典对象的第三种方法这是由 Stock Overflow 上的某人建议的，对他来说很有效，但对我来说则不然。我不太懂vba，无法调试它。

Sub build_FolderLevels(dFMs As Scripting.Dictionary, _
                   Optional sFM As String = "", _
                   Optional iFLDR As Long = 0)
Dim d As Long, fp As String, vFMs As Variant

If CBool(dFMs.Count) Then
    vFMs = dFMs.Keys
    For d = LBound(vFMs) To UBound(vFMs)
        vFMs(d) = vFMs(d)
    Next d
Else
    vFMs = Array(sFM)
End If
dFMs.RemoveAll

For d = LBound(vFMs) To UBound(vFMs)
    fp = Dir(vFMs(d), iFLDR)
    Do While CBool(Len(fp))
        dFMs.Add Key:=Left(vFMs(d), InStrRev(vFMs(d), Chr(92))) & fp, _
                 Item:=iFLDR
        fp = Dir
    Loop
Next d

结束子

Sub main()

Dim fm As Long, sFM As String, vFMs As Variant, sMASK As String
Dim fn As Variant, dFNs As New Scripting.Dictionary

sFM = Environ("TMP") & "\QSHWRA\FCS*\FUNCTION_BLOCK\DR*\*.edf"
If UBound(Split(sFM, Chr(42))) < 2 Then Exit Sub  '<~~possibly adjust this safety
sFM = Replace(sFM, "/", "\")
vFMs = Split(sFM, Chr(92))

sMASK = vFMs(LBound(vFMs))
For fm = LBound(vFMs) + 1 To UBound(vFMs)
    sMASK = Join(Array(sMASK, vFMs(fm)), Chr(92))
    If CBool(InStr(1, vFMs(fm), Chr(42))) Or fm = UBound(vFMs) Then
        build_FolderLevels dFNs, sFM:=sMASK, iFLDR:=Abs((fm < UBound(vFMs)) * vbDirectory)
        sMASK = vbNullString
    End If
Next fm

'list the files
For Each fn In dFNs
    Debug.Print "from dict: " & fn
Next fn

dFNs.RemoveAll: Set dFNs = Nothing
End Sub

Answer 1

我建议您浏览主目录下的所有子文件夹，只收集符合您条件的文件。我可能会使用 WindowsShell 和诸如 Dir MainFolder\*.edf/B/S (裸格式和递归开关设置)之类的东西，然后只保存或收集所需子文件夹中的那些文件。但您也可以使用 DIR 或 FileSystemObject 和递归执行类似的操作。