Найти файлы, содержащие указанные c слов в указанном файле и его подпапках, скопировать и вставить их в указанный файл

Question

Я пишу электронную таблицу, чтобы ускорить выполнение задач с добавленной стоимостью, которые мы имеем, когда предложение конвертируется в заказ. Один из этих процессов потребовал, чтобы команда скопировала файлы из одной папки в другую папку для команды проекта. Я искал в Интернете и нашел здесь несколько вещей, ни одна из которых не дает мне именно то, что мне нужно, и, поскольку я новичок в этом, объединение их всех находится за пределами моего уровня в данный момент. Ниже приведено описание того, что мне потребуется. Любая помощь будет принята с благодарностью.

Короче говоря, я хотел бы найти в указанной папке и ее подпапках любой файл, содержащий слова в названии, такие как «Продано», «Контракт» или «Класс». ID ", затем я хотел бы, чтобы он скопировал эти файлы в другую указанную папку.

(1) Поиск любых файлов в структуре определенных подпапок, где имена файлов содержат, например,« Продано ». (2) Затем, когда все файлы будут найдены, я sh скопирую эти файлы в другую папку

Sub sbCopyingAFile()

'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String

'This is Your File I want to copy, but i want the value to be any file that contains "as sold","Class ID" or_
'"Contract" in the file name. the "*As*Sold*" doesnt work at all, but if i write the exact file name it does work.
'I will have multiple files that say either of of the above so will need it to do all files
sFile = "*As*Sold*"

'Source folder, i would like this to look at the source folder and find any file as above in the specified folder
'and all subfolders, this only looks in that folder
sSFolder = "C:\Users\steven.byrne\Desktop\Test Folder 1\"

'Paste the all files into this folder
sDFolder = "C:\Users\steven.byrne\Desktop\Test Folder 2\"

'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
    MsgBox "Specified File Not Found", vbInformation, "Not Found"

'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
    FSO.CopyFile (sSFolder & sFile), sDFolder, True
    MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
    MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If

End Sub

Любая помощь или предложения будут очень благодарны, спасибо: -)

Answer 1

Я также изучал и успешно протестировал следующую функцию, которую вы можете использовать для поиска в подпапке и копирования файлов в место назначения.

Но чтобы это работало:

Добавить FileSystemObject в вашем справочнике VBA

Чтобы это работало, вам необходимо:

1. Go в VBE (редактор Visual Studio)
2. Открыть Ссылки - VBAProject из меню Tools\References
3. Когда появится следующее диалоговое окно, выполните поиск Microsoft Scripting Runtime и Tick / Check it.

Подпрограмма поиска и копирования:

'sFolderToSearch:= Location where you want to do the search (No "\" at the end)
'sFolderDestination:= Location where you want to found files to be copied (No "\" at the end)
'sListOfKeysToSearch:= a List of String containing key to search separated by sDelimiter (ex. "As Sold", "Contract" or "Class ID")
'sDelimiter:= It is the Delimiter you use to split your sListOfKeysToSearch
'             For Example:  sListOfKeysToSearch = "As Sold|Contract|Class ID", here by default the delimiter is "|".
Sub SearchAndCopy(sFolderToSearch As String, _
                    sFolderDestination As String, _
                    sListOfKeysToSearch As String, _
                    Optional sDelimiter As String = "|")

On Error GoTo CleanUp

Dim arrSearchKey() As String
Dim FSO As Object 'FileSystemObject
Dim foFolder As Folder
Dim foSubFolder As Folder
Dim fFile As file
Dim i As Long, nCopiedCnt As Long

    'Get the Folder List from sFolderToSearch
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set foFolder = FSO.GetFolder(sFolderToSearch)

    'Convert sListOfKeysToSearch to Array splitting it with the sDelimiter
    arrSearchKey = Split(sListOfKeysToSearch, sDelimiter)

    'nCopiedCnt is the Numbers of Files copied
    nCopiedCnt = 0

    With Application
        'Pause Screen update
        .ScreenUpdating = False

        'Change Cursor to Wait
        .Cursor = xlWait
    End With

    'Duration calculation
    'From here https://www.thespreadsheetguru.com/the-code-vault/2015/1/28/vba-calculate-macro-run-time
    Dim StartTime As Double
    Dim SecondsElapsed As Double

    'Remember time when macro starts
    StartTime = Timer

    'Search all Subfolders within foFolder
    For Each foSubFolder In foFolder.SubFolders
        'Search all files within foSubFolder
        For Each fFile In foSubFolder.Files
            'Test if FileName is the same as each of the search Keys provided
             For i = LBound(arrSearchKey) To UBound(arrSearchKey)
                'If InStr is Positive then the Key is Found within the Filename
                If InStr(1, fFile.Name, arrSearchKey(i), vbBinaryCompare) > 0 Then
                    'Copy the file in the Destination Folder
                    FSO.CopyFile fFile.Path, _
                                sFolderDestination & "\" & fFile.Name, _
                                True                                'Set last Parameter to True if you want to overwite

                    'Increment nCopiedCnt
                    nCopiedCnt = nCopiedCnt + 1
                End If
             Next i
        Next fFile
    Next foSubFolder

    If nCopiedCnt = 0 Then
        'No file found with the search Keys
        MsgBox "No file found with the giving search keys!", vbInformation, "Search successful ..."
    Else
        'Determine how many seconds code took to run
        SecondsElapsed = Round(Timer - StartTime, 2)

        'Confirm how many files were copied
        MsgBox nCopiedCnt & " file(s) successfully Found and Copied in " & SecondsElapsed & " seconds", vbInformation, "Search & Copy successful ..."
    End If

CleanUp:
    With Application
        'Restore Screen update
        .ScreenUpdating = True

        'Restore default Cursor
        .Cursor = xlDefault
    End With

    'Purge Memory
    Set FSO = Nothing
        Exit Sub

ErrorFound:
    MsgBox Err.Description
    Resume CleanUp
End Sub

Следующие заметки уже есть в вашем комментарии и очень важны, когда Вы используете подпрограмму:

• sFolderToSearch: = Место, где вы хотите выполнить поиск (в конце нет "\")
• sFolderDestination : = Место, где вы хотите найти файлы для копирования (без "\" в конце)
• sListOfKeysToSearch: = Список строк, содержащий ключ для поиска, разделенный sDelimiter (например, «Продано», «Контракт» или «Идентификатор класса»)
• sDelimiter: = Это разделитель, который вы используете для разделения вашего sListOfKeysToSearch Например: sListOfKeysToSearch = "As Sold|Contract|Class ID", здесь по умолчанию разделитель - «|».

Как его использовать:

SearchAndCopy "Z:\Archive\My Search Folder","C:\New Folder\Destination","As Sold|Contract|Class ID","|"
'sFolderDestination should not have "\" at the end
'sFolderDestination should not have "\" at the end
'sListOfKeysToSearch is separated with "|" (whatever delimiter you use)
'sDelimiter is Optional. By Default it is "|"

Надеюсь, вам понравится:)

Всего наилучшего!