Hi All,
I have multiple files with different national ID numbers under the source folder, most of the multiple files are named under the same national ID number with additional descriptive text example s12345678B_forms, s12345678B_resume_work permit, licence_s12345678B. Anyone knows the code to copy all the files associate with the national id numbers? I would appreciate any kind souls that would be able to help me with the code on this.
I have multiple files with different national ID numbers under the source folder, most of the multiple files are named under the same national ID number with additional descriptive text example s12345678B_forms, s12345678B_resume_work permit, licence_s12345678B. Anyone knows the code to copy all the files associate with the national id numbers? I would appreciate any kind souls that would be able to help me with the code on this.
VBA Code:
Dim blNotFirstIteration As Boolean
Dim Fil As File
Dim hFolder As Folder, SubFolder As Folder
Dim NameOfFile As String
Dim FSO As Scripting.FileSystemObject
Sub copyfiles()
'Updateby JHey
Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "ID", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = "Please select the original folder:"
If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & ""
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = "Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & ""
For Each xCell In xRg
blNotFirstIteration = False
NameOfFile = ""
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FindFilesInFolders xSPathStr, xVal
If NameOfFile <> "" Then
FileCopy Fil.Path, xDPathStr & "\" & NameOfFile
End If
End If
Next
End Sub
Sub FindFilesInFolders(ByVal HostFolder As String, FileName As String)
If NameOfFile <> "" Then Exit Sub
If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject
Set hFolder = FSO.GetFolder(HostFolder)
' iterate through all files in the root of the main folder
If Not blNotFirstIteration Then
For Each Fil In hFolder.Files
If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
NameOfFile = FSO.GetFileName(Fil.Path)
Exit Sub
End If
Next Fil
' make recursive call, if main folder contains subfolder
If Not hFolder.SubFolders Is Nothing Then
blNotFirstIteration = True
Call FindFilesInFolders(HostFolder, FileName)
If NameOfFile <> "" Then Exit Sub
End If
' iterate through all files in all the subfolders of the main folder
Else
For Each SubFolder In hFolder.SubFolders
For Each Fil In SubFolder.Files
If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
NameOfFile = FSO.GetFileName(Fil.Path)
Exit Sub
End If
Next Fil
' make recursive call, if subfolder contains subfolders
If Not SubFolder.SubFolders Is Nothing Then
Call FindFilesInFolders(HostFolder & "\" & SubFolder.Name, FileName)
If NameOfFile <> "" Then Exit Sub
End If
Next SubFolder
End If
blNotFirstIteration = False
End Sub
Last edited by a moderator:
Thanks for being so unselfishly helpful.
