excel - Excel停止工作，找不到错误

Question

我的 VBA 程序每次运行时都会停止工作。我就是找不到错误。没有错误信息；Excel 只是停止工作。

这是我的代码：

Option Explicit

Public newestFile As Object

Sub Scan_Click()
    Dim row As Integer: row = 2

    Do
        If Sheets("ETA File Server").Cells(row, 1) <> "" Then
            Dim path As String: path = Sheets("ETA File Server").Cells(row, 1)
            If Sheets("ETA File Server").Cells(row, 1) = "Root" Then
                row = row + 1
            Else
                Call getNewestFile(path)
                Sheets("ETA File Server").Cells(row, 10) = newestFile.Name
                Sheets("ETA File Server").Cells(row, 9) = newestFile.DateLastModified
                row = row + 1
            End If
        Else
            Exit Do
        End If
    Loop
    row = 2

End Sub

Private Sub getNewestFile(folderPath As String)
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object

    'get the filesystem object from the system
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(folderPath)


    'go through the subfolder and call itself
    For Each objFile In objFolder.SubFolders
        Call getNewestFile(objFile.path)
    Next

    For Each objFile In objFolder.Files
        If newestFile Is Nothing Then
            Set newestFile = objFile
        ElseIf objFile.DateLastModified > newestFile.DateLastModified Then
            Set newestFile = objFile
        End If
    Next
End Sub

Answer 1

我对您的代码进行了一些更改。这会稍微减慢你的进程，但它不应该崩溃。我测试了 5 行数据，即5 main folders（6883 个子文件夹，46413 个文件），它运行得很好。

测试结束后，删除其中包含subfoldercount或filescount的行

Option Explicit

Public newestFile As Object
Dim subfoldercount As Long, filescount As Long

Sub Scan_Click()
    Dim path As String
    Dim row As Integer: row = 2
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("ETA File Server")

    subfoldercount = 0: filescount = 0

    With ws
        Do
            If .Cells(row, 1).Value = "" Then Exit Do

            path = .Cells(row, 1).Value

            Application.StatusBar = "Processing folder " & path
            DoEvents

            If Not .Cells(row, 1).Value = "Root" Then
                Call getNewestFile(path)

                .Cells(row, 7).Value = subfoldercount
                .Cells(row, 8).Value = filescount
                .Cells(row, 9).Value = newestFile.DateLastModified
                .Cells(row, 10).Value = newestFile.Name

                Set newestFile = Nothing
                subfoldercount = 0: filescount = 0
                row = row + 1
            End If
        Loop
    End With

    Application.StatusBar = "Done"
End Sub

Private Sub getNewestFile(folderPath As String)
    Dim objFSO As Object, objFolder As Object, objFile As Object

    'get the filesystem object from the system
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(folderPath)

    'go through the subfolder and call itself
    For Each objFile In objFolder.SubFolders
        subfoldercount = subfoldercount + 1
        Call getNewestFile(objFile.path)
        DoEvents
    Next


    For Each objFile In objFolder.Files
        filescount = filescount + 1
        If newestFile Is Nothing Then
            Set newestFile = objFile
        ElseIf objFile.DateLastModified > newestFile.DateLastModified Then
            Set newestFile = objFile
        End If
    Next
End Sub