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