How to move files using partial file name? - excel

Question

I learnt how to copy multiple files from a single folder to multiple folders depending on file name in Excel sheet.
Sub MoveSelectedfiles()
Dim FSO As Scripting.FileSystemObject
Dim fl As Scripting.File
Dim sourcefldr As Scripting.Folder
Dim destinationFldr As Scripting.Folder
Dim index As Integer
Dim lastrow As Integer
Set FSO = New FileSystemObject
Set sourcefldr = FSO.GetFolder("E:\Testing\Source")
Set destinationFldr = FSO.GetFolder("E:\Testing\Destination")
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For index = 2 To 10
If (FSO.FileExists(sourcefldr.Path & "\" & Sheet1.Range("A" & index).Value)) Then
FSO.MoveFile sourcefldr.Path & "\" & Sheet1.Range("A" & index).Value, destinationFldr.Path & "\"
End If
Next index
End Sub
I have to define the exact file name. I would like to write even half/incomplete file name.
E.g. If a file name is "Excel training makes easy" and in the Excel sheet I write "Excel training".

Answer 1

Move Files From a List of Partial File Names
You can use the Dir function with wild characters (* and ?) to test if a file exists, e.g.:
Begins with
sFileName = Dir(sFolderPath & sPartialFileName & "*")
Contains
sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
Then you can continue with:
if len(sFileName) > 0 Then ' source file found
Partial File Names
Sub MoveFilesFromListPartial()
Const sPath As String = "E:\Testing\Source"
Const dPath As String = "E:\Testing\Destination"
Const fRow As Long = 2
Const Col As String = "A"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet1
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
If Len(sPartialFileName) > 0 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*")
' or instead, 'Contains' sPartialFileName
'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
If Len(sFileName) > 0 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.MoveFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
MsgBox "Stats" & vbLf _
& "Source files moved: " & sYesCount & vbLf _
& "Source files not found: " & sNoCount & vbLf _
& "Source files existed in destination: " & dYesCount & vbLf _
& "Number of blank cells: " & BlanksCount & vbLf _
& "Number of cells processed: " & lRow - fRow + 1, _
vbInformation
End Sub
Full File Names
Sub MoveFilesFromList()
Const sPath As String = "E:\Testing\Source"
Const dPath As String = "E:\Testing\Destination"
Const fRow As Long = 2
Const Col As String = "A"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet1
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file doesn't exist
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
For r = fRow To lRow
sFileName = CStr(ws.Cells(r, Col).Value)
If Len(sFileName) > 0 Then ' the cell is not blank
sFilePath = sFolderPath & sFileName
If fso.FileExists(sFilePath) Then ' the source file exists
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.MoveFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination folder
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
MsgBox "Stats" & vbLf _
& "Source files moved: " & sYesCount & vbLf _
& "Source files don't exist: " & sNoCount & vbLf _
& "Source files existed in destination: " & dYesCount & vbLf _
& "Number of blank cells: " & BlanksCount & vbLf _
& "Number of cells processed: " & lRow - fRow + 1, _
vbInformation
End Sub