Question

我是VBA上的Google搜索编码器。我的PC上有一个本地文件夹，包含大约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

Answer 1

如何替换该部分（循环）

        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

仅此行：

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

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

1 个答案: