Aug 18 2023 12:27 PM
I'm trying to match using partial file names, then copy all matching files to a subfolder within the source folder.
This is another users pic, but I'm trying to use "TPS" from column D to copy the "TPS report" file into a new folder called "found files" located inside the "document folder" source folder.
Basically, I've got a list of PO#s and a folder with all those POs saved in it, but the full file names have a bunch of extraneous data after the PO# so I'd like to just use those to match them. I found some code from another user (@Subodh_Tiwari_sktneer), but I'm hoping someone can help me tweak it a bit, as I can't seem to get the code to work...
I've gotten it to create the subfolder in the source folder, but I would like to have the program search for partial file names instead of whole names (ex: search for 20448 results in the file labeled: 20448 xxxx-xxxxxxxxxx, xxx-xxx, xxxxx-xx)
CODE:
Sub SearchFiles() Dim ws As Worksheet Dim tbl As ListObject Dim cel As Range Dim rootFolder As String Dim strNameNewSubFolder As String Dim fso As FileSystemObject Dim newFolder As Folder Dim fil As File Dim strFilepath As String Dim newFilePath As String Set fso = New FileSystemObject Set ws = Worksheets("B") Set tbl = ws.ListObjects(1) 'Path of the Source folder with files rootFolder = "C:\Users\sktneer\Documents" If Not fso.FolderExists(rootFolder) Then MsgBox rootFolder & " doesn't exist.", vbExclamation, "Source Folder Not Found!" Exit Sub End If 'files that are found in the Source Folder would be copied to this New Sub-Folder 'Change the name of the Sub-Folder as per your requirement strNameNewSubFolder = "Found Files" If Right(rootFolder, 1) <> "/" Then rootFolder = rootFolder & "/" If Not fso.FolderExists(rootFolder & strNameNewSubFolder) Then fso.CreateFolder rootFolder & strNameNewSubFolder End If Set newFolder = fso.GetFolder(rootFolder & strNameNewSubFolder) tbl.DataBodyRange.Columns(4).Interior.ColorIndex = xlNone For Each cel In tbl.DataBodyRange.Columns(4).Cells strFilepath = rootFolder & cel.Value newFilePath = newFolder.Path & "/" & cel.Value If fso.FileExists(strFilepath) Then cel.Interior.Color = vbYellow Set fil = fso.GetFile(strFilepath) 'The following line will copy the file found to the newly created Sub-Folder fil.Copy newFilePath End If Next cel Set fso = Nothing End Sub
I'm wondering what I would need to add to this code to have it return the correct files using partial file names. Any and all help is massively appreciated.
Thanks in advance!
Aug 18 2023 09:03 PM
Aug 21 2023 05:25 AM
Aug 21 2023 06:56 AM
Aug 21 2023 07:03 AM
Aug 21 2023 01:54 PM
Aug 21 2023 04:39 PM
Sub test()
Dim r%, i%
Dim arr
With Worksheets("Sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:e" & r)
For i = 2 To UBound(arr)
SearchAndCopyFiles arr(i,4)
rem column 4 contains the fileNamePattern
Next
End With
End Sub
Sub SearchAndCopyFiles(fileNamePattern)
Dim fso As Object ' FileSystemObject
Dim sourceFolder As String
Dim destinationFolder As String
Dim fileNamePattern As String
Dim file As Object ' File
Dim foundFilesCount As Integer
' Set the source folder path
sourceFolder = "C:\Path\To\Source\Folder"
' Set the destination folder path
destinationFolder = "C:\Path\To\Destination\Folder\Found Files"
' Set the partial file name pattern
rem fileNamePattern = "*20448*"
' Create a FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Check if the source folder exists
If Not fso.FolderExists(sourceFolder) Then
MsgBox "Source folder does not exist."
Exit Sub
End If
' Check if the destination folder exists and create it if not
If Not fso.FolderExists(destinationFolder) Then
On Error Resume Next
fso.CreateFolder destinationFolder
On Error GoTo 0
' Check if the creation was successful
If Not fso.FolderExists(destinationFolder) Then
MsgBox "Unable to create the destination folder."
Exit Sub
End If
End If
' Loop through all files in the source folder
For Each file In fso.GetFolder(sourceFolder).Files
' Check if the file name matches the pattern
If fso.GetFileName(file.Path) Like fileNamePattern Then
' Copy the file to the destination folder
fso.CopyFile file.Path, destinationFolder & "\" & fso.GetFileName(file.Path)
foundFilesCount = foundFilesCount + 1
End If
Next file
MsgBox "Found files: " & foundFilesCount
End Sub