Question

我需要获取文件夹名称，其中包含我需要在具有大约6000个文件夹的服务器中搜索目录的路径。我有以下代码片段来运行该文件夹并获取带路径的文件夹名称。它在本地目录中工作正常，但是当我在服务器目录上运行相同的代码时，它在打印86个文件夹名称后失败。在具有超过6000个文件夹的服务器位置上运行时代码失败。

Private Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer
Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Temp")
i = 1
'loops through each folder in the directory and prints their names and path
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
MsgBox "This may take a long time: press ESC to cancel"
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
    'print folder name
    Cells(i + 1, 1) = objSubFolder.Name
    'print folder path
    Cells(i + 1, 2) = objSubFolder.Path
    i = i + 1
Next objSubFolder
handleCancel:
If Err = 18 Then
 MsgBox "You cancelled"
End If
End Sub

Answer 1

经过多次讨论后，最终的代码才能正常工作，效果很好。

Sub PrintFolders()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim i As Integer
    Dim Folder_Name As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ""
    On Error GoTo CleanFail

    Set wb = ThisWorkbook
    Set wsControl = wb.Sheets("Control"): Set wsOutput = wb.Sheets("Output")
    Folder_Name = wsControl.Cells(1, 2)
    If Folder_Name = "" Then
        MsgBox "Path location is not entered. Please enter path"
        wsControl.Cells(1, 2).Select
        End
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(Folder_Name)

    i = 1
    Dim MyArr() As Variant
    ReDim MyArr(1 To i, 1 To 2)

    Application.EnableCancelKey = xlErrorHandler
    Const IterationsToUpdate As Integer = 10
    For Each objSubFolder In objFolder.subfolders
        MyArr(i, 1) = objSubFolder.Name
        MyArr(i, 2) = objSubFolder.Path
        i = i + 1
            MyArr = Application.Transpose(MyArr)
            ReDim Preserve MyArr(1 To 2, 1 To i)
            MyArr = Application.Transpose(MyArr)
        If i Mod IterationsToUpdate = 0 Then
            Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
            DoEvents
        End If
    Next objSubFolder
    Application.StatusBar = ""

    wsOutput.Rows("2:1048576").Delete
    Dim Destination As Range
    Set Destination = wsOutput.Range("A2")
    Destination.Resize(UBound(MyArr, 1), UBound(MyArr, 2)).Value = MyArr
    wsOutput.Columns.EntireColumn.AutoFit: wsOutput.UsedRange.HorizontalAlignment = xlCenter
    wsOutput.Activate

    MsgBox ("Done")

CleanExit:
    Application.StatusBar = False
    Application.StatusBar = ""
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

CleanFail:
    Const MsgTitle As String = "Operation not completed"
    If Err.Number = 18 Then
        MsgBox "Operation was cancelled.", vbInformation, MsgTitle
    Else
        MsgBox "An error has occurred: " & Err.Description, vbCritical, MsgTitle
    End If
    Resume CleanExit

End Sub

从服务器目录中获取文件夹名称

1 个答案: