I am new to writing codes, i just have learnt as of how to copy multiple files from a single folder to multiple folders depending on file name you define in excel sheet, so here is the code
Sub MoveSelectedfiles()
Dim FSO As Scripting.FileSystemObject
`enter code here`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
This has worked, however, in this code i have to define the exact file name, whereas i would like to request if there is any option by which if i write even half/incomplete file name it will read it and execute.
e.g. If a file name is "Excel training makes easy" and in excel sheet if i only write "Excel training" the code should select that file, rather than i have to write exact names everytime.
Can anyone help in this regard.
thanks
CodePudding user response：
Move Files From a List of Partial File Names
You can use the
Dirfunction 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
CodePudding user response：
Dear Sir I have tested the code u have provided for partial list & it worked perfectly fine. I would like to ask if folder contains more than 1 file where initial name of files are same e.g.
1 file name "Excel training makes easy" & 2 file name "Excel training for beginners"
the current code moves 1 file at a time and in order to move both files i have to press the "run" button 2 times, is there any way if the initial names of files are same it should move all those. I have 2 last questions i will ask again. Thank you so much sir