Question

我的任务是由我的上司在工作中创建和更新一系列基于VBA的excel附加程序。其中一个程序是一个实用程序，它比较两个文件夹的内容，并给出不同文件的列表。大多数程序都运行良好，但我遇到了代码的一部分问题;即，负责收集要检查的文件的所有文件名的部分。

该部分本身确实起作用，大部分时间都没有问题，但有时会花费过多的时间。我一直在为该实用程序的整个开发运行相同的数据集测试，所以我知道问题不是被搜索的文件数量（数百个，最终将近千个）。我的问题是代码部分与其时序非常不一致。

有问题的代码部分在这里：

Sub GetFileList(ByRef FileSpec() As String, FileArray() As FileInfo, FoldIndex As Integer)
'FileSpec - an array of strings that correspond to the filtered list of file extensions to be searched
'FileArray - an array of strings that will end up holding the complete list of relevant file names
'FoldIndex - an integer that corresponds to which folder is being searched (1 or 2)
'Returns an array of filenames that match FileSpec
'If no matching files are found, returns an error messagebox
'Arbitrarly takes inordinate  amount of time, sometimes upwards of 20 seconds, to finish running.
'Usually when the filtering has been changed.
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
For i = LBound(FileSpec) + 1 To UBound(FileSpec)
    FileName = Dir(FileSpec(i))

'Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount).FileName = FileName
        FileName = Dir()
        Select Case FoldIndex
            Case 1
                Call FormFunctionality.UpdateResults(FileCount & ": " & FileArray(FileCount).FileName & vbCrLf, "")
            Case 2
                Call FormFunctionality.UpdateResults("", FileCount & ": " & FileArray(FileCount).FileName & vbCrLf)
        End Select
    Loop
Next i
If FileCount = 0 Then GoTo NoFilesFound
Exit Sub

'Error handler
NoFilesFound:
ReDim FileArray(1)
FileArray(1).FileName = "Error"
MsgBox ("Error: No files found of requested type" & vbCrLf & "Please review folders and requested file types.")
End
End Sub

Sub UpdateResults(Str1 As String, Str2 As String)
'Prints strings to the results window text boxes
RbtUtilResultScreen.Folder1Results.Text = RbtUtilResultScreen.Folder1Results.Text & Str1
RbtUtilResultScreen.Folder2Results.Text = RbtUtilResultScreen.Folder2Results.Text & Str2
RbtUtilResultScreen.Folder1Results.SetFocus
RbtUtilResultScreen.Folder2Results.SetFocus
End Sub

时间不一致变化很大。对于要搜索的~350个文件，生成文件列表的平均时间约为2秒。有时候，那段时间会达到10秒或20秒，这是坦率地说是不可接受的。搜索到更多文件会变得更糟，我需要花费大约一分钟和三十秒才能获得~800个文件（其中平均值仍为3秒）。

我的问题是这样的：有什么明显的东西我做错了，还是有一种更好的办法处理阅读文件，因为我忽略了？什么可能导致程序中的这种不一致？

如果需要更深入的时间信息或代码的其他部分，我将提供。我不相信我可以访问我一直在运行测试的数据。

Answer 1

您的代码中的原因尚不清楚。但是，您可以优化某些部分，这可能会缩短时间。也就是说，每次迭代都会ReDim，这会导致内存管理开销。相反，ReDim固定数量的项目，例如：

    Dim nElms As Integer
    ...
    nElms = 0
    FileCount = 0

    Do While FileName <> ""
        FileCount = FileCount + 1
        If (FileCount > nElms) Then
            nElms = nElms + 250
            ReDim Preserve FileArray(1 To nElms)
        EndIf

Answer 2

保罗在他的回答中建议你需要使用＆＃34;固定步骤＆＃34;重新定义数组似乎是一个问题。

另一个问题似乎是不断更新表单文本以显示进度。如果它不是太关键，那么你可以考虑将其改为如下所示。

在Loop之前的代码开头声明字典对象。

Dim objDict As Object objDict = CreateObject("Scripting.Dictionary")

然后修改后的块将如下所示。

For i = LBound(FileSpec) + 1 To UBound(FileSpec)
    FileName = Dir(FileSpec(i))
    objDict.RemoveAll
    Do While FileName <> ""
        If Not objDict.Exists(FileName) Then objDict.Add FileName, FileName
        FileName = Dir()
    Loop
    Select Case FoldIndex
        Case 1
            Call FormFunctionality.UpdateResults(objDict.Count & ": " & FileName & vbCrLf, "")
        Case 2
            Call FormFunctionality.UpdateResults("", objDict.Count & ": " & FileName & vbCrLf)
    End Select
Next I

在备份上测试它！

VBA：阅读花费不同时间的文件名列表

2 个答案: