Excel VBA 循环在小数据集上运行良好，但在大数据集上花费的时间呈指数增长

Question

我在 VBA 中创建了一个宏，它应该检查 Excel 工作表上的零件编号与文件目录中零件的文件名。脚本是这样的：

Sub scanDirectory()

    Dim path As String
    Dim currentPath As String
    Dim nameOfFile As String
    Dim counterA As Integer
    Dim success As Integer
    Dim endTester As String
    Dim draw As Integer
    'put the path to your folder here along with an \
    path = "\C:\Users\joe.blow\Documents\"

    counterA = 8
    Do Until counterA > 4294
        nameOfFile = Sheets("Sheet0").Cells(counterA, 2)

        currentPath = Dir(path)
        success = 0
        draw = 0
        Do Until currentPath = vbNullString
            Debug.Print currentPath

            'Success for Model
            endTester = nameOfFile + ".SLDPRT"
            If currentPath = endTester Then
                Sheets("Sheet0").Cells(counterA, 5) = "Y"
                success = 1
            End If
            endTester = nameOfFile + ".sldprt"
            If currentPath = endTester Then
                Sheets("Sheet0").Cells(counterA, 5) = "Y"
                success = 1
            End If

            'Success for Assembly
            endTester = nameOfFile + ".SLDASM"
            If currentPath = endTester Then
                Sheets("Sheet0").Cells(counterA, 5) = "Y"
                success = 1
            End If

            'Succees for Drawing
            endTester = nameOfFile + ".SLDDRW"
            If currentPath = endTester Then
                Sheets("Sheet0").Cells(counterA, 6) = "Y"
                draw = 1
            End If
            endTester = nameOfFile + ".slddrw"
            If currentPath = endTester Then
                Sheets("Sheet0").Cells(counterA, 6) = "Y"
                draw = 1
            End If

            If draw = 0 Then
                Sheets("Sheet0").Cells(counterA, 6) = "N"
            End If

            If success = 0 Then
                Sheets("Sheet0").Cells(counterA, 5) = "N"
            End If

            currentPath = Dir()
        Loop
    counterA = counterA + 1
    Loop  'NextLine' End Sub

它的工作原理是逐行检查每个单元格与整个文件树，检查文件扩展名的每个排列。然后，如果文件存在或不存在相应的“Y”或“N”，它将放入一个空列。它同时对模型和图纸执行此操作。

它适用于 1 小时，那么即使它是“无响应”，它也会完成运行。有没有更好的方法来运行它，这样它就不会花费那么长时间或

Answer 1

通过使用内置的 FileSystemObject，您可以直接检查给定路径中是​​否存在文件，因此无需遍历每个单元格的文件列表。

试一试，看看它是否有帮助，显着缩短代码，提高可读性并减少处理器工作:)

Option Explicit

Sub scanDirectory()

    Application.ScreenUpdating = False

    Dim path As String
    'put the path to your folder here along with an \
    path = "\C:\Users\joe.blow\Documents\"

    Dim counterA As Integer
    counterA = 8

    Do Until counterA > 4294

        'grab file name from cell
        Dim nameOfFile As String
        nameOfFile = Sheets("Sheet0").Cells(counterA, 2)

        Dim fso As New FileSystemObject 'be sure to check Microsoft Scripting Runtime in Tools > References

        'check for Drawing
        Sheets("Sheet0").Cells(counterA, 6).Value = IIf(fso.FileExists(path + nameOfFile + ".SLDDRW"), "Y", "N")

        'check for Model or Assembly
        Dim maCheck As Boolean
        If fso.FileExists(path + nameOfFile + ".SLDPRT") Or fso.FileExists(path + nameOfFile + ".SLDASM") Then maCheck = True

        Sheets("Sheet0").Cells(counterA, 5).Value = IIf(maCheck, "Y", "N")
        maCheck = False

        counterA = counterA + 1

    Loop  'NextLine

End Sub