使用 excel vba 使用 FSO 方法将特定文件扩展名复制到另一个文件夹

Question

尝试使用 fso 技术从源文件夹 C:\ (V) 复制到目标文件夹 C:(All) 但运行代码给出消息运行时错误 53。找不到文件

我想要实现的是从源文件夹 C:\ V 复制所有 xlsx 文件，其中还包含其他文件扩展名 pdf、csv、txt、word..

所有 xlsx 将被复制到文件夹 C:\ALL，

下面这一行出现运行时错误

****FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath****

Sub copy_specific_files_in_folder()




Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String

sourcePath = "c:\V"

destinationPath = "c:\all\"


fileExtn = " * .xlsx"


If Right(sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(sourcePath) = False Then

MsgBox sourcePath & " does not exit"

Exit Sub

End If

If FSO.FolderExists(destinationPath) = False Then
MsgBox destinationPath & " does not exit"

Exit Sub
End If

FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath

copy_files_from_subfolders

MsgBox "your files have been copied from subfolders of " & sourcePath & "to" & destinationPath



End Sub




Sub copy_files_from_subfolders()

Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object

sourcePath = "c:\V"

targetpath = "c:\all\"


If Right(sourcePath, 1) <> “ \ ” Then sourcePath = sourcePath & “ \ ”

Set FSO = CreateObject(“scripting.filesystemobject”)
Set fld = FSO.GetFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right(fsoFile, 4) = “xlsx” Then
fsoFile.Copy targetpath
End If
Next
Next
End If

End Sub

Answer 1

您好，将 fileExtn = " * .xlsx" 更改为 fileExtn = "*.xlsx"，这应该可以解决您的问题。

编辑

下面的代码应该修复您的其他子过程。

Sub copy_files_from_subfolders()

Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object

sourcePath = "c:\V"

targetpath = "c:\all\"


If Right(sourcePath, 1) <> "\" Then sourcePath = sourcePath & "\"

Set FSO = CreateObject("scripting.filesystemobject")
Set fld = FSO.GetFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right(fsoFile, 4) = “xlsx” Then
fsoFile.Copy targetpath
End If
Next
Next
End If

End Sub

Answer 2

我已经检查了“Sub copy_specific_files_in_foldera()”的工作原理，它将主目录中的所有文件从 c:\v 复制到 c:\all 但在应用您的编辑时。我得到编译错误消息变量未定义 sourcePath 。黄色的“Sub copy_files_from_subfolders()”。

Sub copy_specific_files_in_foldera()

将 FSO 调暗为对象 将 sourcePath 调暗为字符串 将destinationPath 调暗为字符串 将文件扩展为字符串

sourcePath = "c:\V"

destinationPath = "c:\all\"

fileExtn = "*.xlsx"

If Right(sourcePath, 1) "\" Then 源路径 = 源路径 & "\" 结束如果

设置 FSO = CreateObject("scripting.filesystemobject")

如果 FSO.FolderExists(sourcePath) = False 则

MsgBox sourcePath & "不退出"

退出子

如果结束

如果 FSO.FolderExists(destinationPath) = False 那么 MsgBox destinationPath & "不退出"

退出子 结束如果

FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath

'copy_files_from_subfolders'暂停'

MsgBox "您的文件已从 " & sourcePath & "to" & destinationPath 的子文件夹复制

结束子

Answer 3

通常在函数/子程序中硬编码太多。

将变量保留为输入： 我添加了对 Microsoft.Scripting.Runtime 的引用

Sub CopyFiles(extension As String, sourceFolder As String, targetFolder As String, recursive As Boolean)
    Dim fso As New FileSystemObject
    Dim src As folder, dest As folder

    Set src = fso.GetFolder(sourceFolder)
    Set dest = fso.GetFolder(targetFolder)

    Dim srcFile As File
    For Each srcFile In src.Files
        Dim srcFilepath As String
        srcFilepath = srcFile.Path
        If Right(srcFilepath, Len(srcFilepath) - InStrRev(srcFilepath, ".") + 1) = extension Then   'extension includes the "."
            srcFile.Copy targetFolder, True 'I set Overwrite to True
        End If
    Next srcFile

    If recursive Then   'If recursive is True then will go through all subfolders recursively
        Dim subDir As folder
        For Each subDir In src.SubFolders
            CopyFiles extension, subDir.Path, targetFolder, True
        Next subDir
    End If
End Sub

Sub testCopy()
    CopyFiles ".xlsm", "C:\Source", "C:\Destination\", True
End Sub