Использование Excel VBA для копирования определенных расширений файлов в другую папку с помощью метода FSO

Question

Попытка использовать технику fso для копирования из исходной папки C: \ (V) в целевую папку C: (Все), но с кодом выполнения выдаёт ошибку времени выполнения сообщения 53. Файл не найден

То, что я пытаюсь добиться, - это скопировать весь файл xlsx из исходной папки C: \ V, которая также содержит другие расширения файлов pdf, csv, txt, word ..

Все xlsx будут скопированы в папку C: \ ALL,

Получение ошибки времени выполнения в этой строке ниже

**** FSO.CopyFile Источник: = sourcePath & fileExtn, пункт назначения: = 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

Я проверил "Sub copy_specific_files_in_foldera ()" работает, он копирует все файлы в главном каталоге из c: \ v в c: \ all, но при применении вашего редактирования. Я получаю сообщение об ошибке компиляции, переменная не определена sourcePath . «Sub copy_files_from_subfolders ()» желтым цветом.

Sub copy_specific_files_in_foldera()

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

sourcePath = "c: \ V"

destinationPath = "c: \ all \"

fileExtn = "* .xlsx"

Если верно (sourcePath, 1) <> "\" Тогда sourcePath = sourcePath & "\" Конец, если

Установить FSO = CreateObject ("scripting.filesystemobject")

Если FSO.FolderExists (sourcePath) = False Тогда

MsgBox sourcePath & "не выходит"

Выход Sub

End If

Если FSO.FolderExists (destinationPath) = False Тогда MsgBox destinationPath & "не выходит"

Выход Sub Конец, если

FSO.CopyFile Источник: = sourcePath & fileExtn, пункт назначения: = destinationPath

'copy_files_from_subfolders' suspend '

MsgBox "Ваши файлы были скопированы из подпапок" & sourcePath & "в" & destinationPath

End Sub

Answer 2

Как правило, слишком много жесткого кодирования в функциях / подпрограммах.

Сохранить переменные в качестве входных данных: Я добавил ссылку на 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

Answer 3

Привет, измените 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