每次运行时,我的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
答案 0 :(得分:0)
我对您的代码进行了一些更改。这会使你的过程减慢一点,但不应该崩溃。我测试了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