改进现有VBA代码以更快地复制文件

我是VBA上的谷歌搜索编码器。 我的电脑里有一个本地文件夹，里面有5000多个PDF文件。 我决定将pdf分类到同名文件夹中。代码的执行非常长，因为代码必须循环5000+才能进行相应的排序。下面的代码工作正常。我也能忍受

只是出于好奇，我发布了这个问题，如果有一种方法可以更快地完成这项任务

Sub Create_FoldersAndExtractFiles()
    Dim sh1 As Object

    'for going through the files Dim FSO As Scripting.fileSystemObject Dim
    SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    fname As String

    Set fso = New Scripting.FileSystemObject

    'http://excelspreadsheetshelp.blogspot.com penAt = "My computer:\"

    Set sh1 = ThisWorkbook.Sheets("Sheet1")
    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, OpenAt)

    'Set the folder to that selected. (On error in case cancelled)

    On Error Resume Next
    scr_Folder = ShellApp.self.Path

    'create the folders where-ever the workbook is saved

    lrow = sh1.Range("a" & Rows.Count).End(xlUp).Row

    If lrow = 1 Then
        MsgBox "No data to create the folder"
    Else
        For i = 2 To lrow
            fname = sh1.Range("a" & i)

            'to create a new folder
            If Len(Dir(ActiveWorkbook.Path & "\" & fname, vbDirectory)) = 0 Then
                MkDir (scr_Folder & "\" & fname)
            End If

            'to move the file into a folder
            dst_folder = scr_Folder & "\" & fname

            Set SourceFolder = fso.GetFolder(scr_Folder)

            For Each FileItem In SourceFolder.Files
                mname = Left(FileItem.NAME, InStr(1, FileItem.NAME, ".") - 1)

                If InStr(LCase(mname), LCase(fname)) Then
                    fso.MoveFile Source:=scr_Folder & "\" & mname & "*.*", Destination:=dst_folder
                End If
            Next
        Next

        Set FileItem = Nothing
        Set SourceFolder = Nothing
        Set fso = Nothing
    End If
    MsgBox "Done"
End Sub

---

更换部分（回路）怎么样

仅此一行：

fso.MoveFile Source:=scr_Folder & "\*" & fname & "*.*", Destination:=dst_folder

---

下一步，在恢复时消除错误-它是否掩盖了任何错误？是否有特定的约束迫使您从Excel内部执行此操作？这看起来像是一个简单的XCopy候选项。@不，没有约束。这就是我知道的方法。。。任何建议都会有帮助。如果此代码正常工作，它将更适合codereview.stackexchange.com您的代码循环文件夹数x文件数。这将远远超过5000次迭代。尝试循环一次以创建文件夹，然后循环一次以移动文件。

fso.MoveFile Source:=scr_Folder & "\*" & fname & "*.*", Destination:=dst_folder