Help on Moving file to another folder, using partial filename

Hello, I got this code from this site but I looking to edit it. I need to edit the filename search feature. Examples in cell A2 have filename "Town" but the file in the folder is "Town_", is there a code that will read the filename before the underscores in the folder? Then move the file to the new folder.

Thank you

Code:

---

Sub movefiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object
' On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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) & ""
Call sMoveFiles(xRg, xSPathStr, xDPathStr)
End Sub

---

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "", xStr & "")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Coun t = 0) Then
RmDir xStr
End If
Next
End Sub

---

1. I added CODE tags to your Excel post - you can use the [#] icon to add them to highlight the macro and do some formatting

2. I deleted your Outlook post with the same topic

How do I delete, I didn't see that option? I did try to delete the outlook post

Seems like the easiest route would be...

Code:

---

Dim TempSplit As Variant
TempSplit = Split(xSPathStr, "_")
xSPathStr= TempSplit(0)
Call sMoveFiles(Xrg, xSPathStr, xDPathStr)

---

HTH. Dave

Where would I place the code?

Code:

---


Sub movefiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object
' On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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) & "\"
Call sMoveFiles(xRg, xSPathStr, xDPathStr)
End Sub

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "\" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "\", xStr & "\")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Then
RmDir xStr
End If
Next
End Sub

---

After reviewing this again, I'm not that certain that code will help. It may be better to do this...

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
Dim TempSplit As Variant
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
TempSplit = Split(xVal, "_")
xVal = TempSplit(0)
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "", xStr & "")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Then
RmDir xStr
End If
Next
End Sub

---

Trial and see what happens. Dave

I will test the code now. Thanks

Attachment 26272

The code is not going through the codes. Its stopping at the yellow break point. Its reading the source folder and destination folder

Quote:

---

Originally Posted by Dave

After reviewing this again, I'm not that certain that code will help. It may be better to do this...

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
Dim TempSplit As Variant
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
TempSplit = Split(xVal, "_")
xVal = TempSplit(0)
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "", xStr & "")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Then
RmDir xStr
End If
Next
End Sub

---

Trial and see what happens. Dave

---

Attachment 26273
Seem it's not seeing the .CVS files in the folder. I am still new at this stuff.

Code:

---

TempSplit = Split(CSTR(xVal)), "_")

---

Change that for now. What is the actual problem? RU creating bad file names and trying to fix them? Dave

I am trying to use list of file name in excel to move the files in the original folder to another destination folder. The problem is the filename in excel is Town but the file has a longer name, that's separate by underscore. So the file is Town_es-the date. I am looking to capture the filename in the source folder before the underscore.

Quote:

---

Originally Posted by Dave

Code:

---

TempSplit = Split(CSTR(xVal)), "_")

---

Change that for now. What is the actual problem? RU creating bad file names and trying to fix them? Dave

---

That code didn't work either,

This is the original VBA Macro, that works if I had the entire filename in the source folder, on the excel sheet. I only have the name before the underscore on the excel sheet.

Code:

---

Sub movefiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object
' On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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) & "\"
Call sMoveFiles(xRg, xSPathStr, xDPathStr)
End Sub

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim xCell As Range
Dim xVal As String
Dim xFolder As Object
Dim fso As Object
Dim xF As Object
Dim xStr As String
Dim xFS As Object
Dim xI As Integer
On Error Resume Next
If Dir(xDPathStr, vbDirectory) = "" Then
MkDir (xDPathStr)
End If
For xI = 1 To xRg.Count
Set xCell = xRg.Item(xI)
xVal = xCell.Value
If TypeName(xVal) = "String" And Not (xVal = "") Then
On Error GoTo E1
If Dir(xSPathStr & xVal, 16) <> Empty Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
End If
E1:
Next xI
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.SubFolders
xStr = xDPathStr & "\" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
Call sMoveFiles(xRg, xF.ShortPath & "\", xStr & "\")
If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Then
RmDir xStr
End If
Next
End Sub

---

OK back to the start.... what exactly is in your ws? Is it the whole path like "C:\YourFolder_Name" or just "YourFolder_Name"? Dave
ps. you R adding a space here [/code ] after the "e"

Quote:

---

Originally Posted by Dave

OK back to the start.... what exactly is in your ws? Is it the whole path like "C:\YourFolder_Name" or just "YourFolder_Name"? Dave
ps. you R adding a space here [/code ] after the "e"

---

The whole path, C:\YourFolder_Name". The macro works. Let me clarify a little. So I have an excel sheet with filename in A2 cell "Town". Now those filename in A2 cell are in the source folder with the full filename "Town_es-04032020.csv. I know the macro works as i manually add the full filename "Town_es-04032020.csv" and the file was moved to the destination folder. So it must be a way to have the macro compare the filename in the source folder before the underscore. Thank you

" So it must be a way to have the macro compare the filename in the source folder before the underscore." I don't understand. Please explain your desired outcome. The code seemed to work if the full path was in the cell. Dave

Quote:

---

Originally Posted by Dave

" So it must be a way to have the macro compare the filename in the source folder before the underscore." I don't understand. Please explain your desired outcome. The code seemed to work if the full path was in the cell. Dave

---

I am uploading a zip file. With control sheet with the macro code and the Filename in Cell A2 and source folder with the files. Hopefully this will help to understand what I am trying to do. Let me know if the file was updated correctly to you. Thanks again

Apologies for the delayed responding. It's a whole lot easier to help when U have the file.
Thanks for posting it. I assume U just want to copy all files with the name selected from the
worksheet from the source folder to the destination folder while maintaining the original file name.
The movefiles code is OK. Here's code for the smoveFiles which seems to work. HTH. Dave

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Sub

---

Quote:

---

Originally Posted by Dave

Apologies for the delayed responding. It's a whole lot easier to help when U have the file.
Thanks for posting it. I assume U just want to copy all files with the name selected from the
worksheet from the source folder to the destination folder while maintaining the original file name.
The movefiles code is OK. Here's code for the smoveFiles which seems to work. HTH. Dave

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Sub

---

---

Thank you, I'll try it out when I get home

Quote:

---

Originally Posted by Xtremedesign

Thank you, I'll try it out when I get home

---

I do want the files to move, I dont want to copy. The macro worked. I just need to add the move code. Thank

So the file that U wanted transferred from the source folder ends up in the destination folder as U wanted? Do you want to remove the original file? The file has moved so I don't understand "need to add the move code" Dave

Quote:

---

Originally Posted by Dave

So the file that U wanted transferred from the source folder ends up in the destination folder as U wanted? Do you want to remove the original file? The file has moved so I don't understand "need to add the move code" Dave

---

Yes, remove the original file,

This should do it...

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
Kill xSPathStr & xF.Name
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Sub

---

Quote:

---

Originally Posted by Dave

This should do it...

Code:

---

Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
Kill xSPathStr & xF.Name
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Sub

---

---

When I select more than 1 cell I get an error "mismatch". That's only when I click on more that one filename in the cell. Anyway around that? Thanks

Do U want to move more than 1 file at a time or just avoid this? Dave

Quote:

---

Originally Posted by Dave

Do U want to move more than 1 file at a time or just avoid this? Dave

---

Move more than 1 file at a time.

That changes things a bit. Trial this. Dave

Code:

---

Option Explicit
Sub MoveFiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object, TempRange As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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 TempRange In xRg
If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
End If
Next TempRange
End Sub
Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
'Kill xSPathStr & xF.Name
fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

---

Quote:

---

Originally Posted by Dave

That changes things a bit. Trial this. Dave

Code:

---

Option Explicit
Sub MoveFiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object, TempRange As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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 TempRange In xRg
If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
End If
Next TempRange
End Sub
Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
'Kill xSPathStr & xF.Name
fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

---

---

The Macro works, but its hours glasses if I try to move a lot of files. Is there a code that I can add for the macro could handle moving large population of files? Thanks

More new info which I hadn't considered. This should speed things up somewhat. Dave

Code:

---

Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
Kill xSPathStr & xF.Name
'fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
Exit Function
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

---

Maybe trial using movefile to see if it's any quicker as well...

Code:

---

Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.moveFile xSPathStr & xF.Name, xDPathStr & xF.Name ', True
'remove original file
'Kill xSPathStr & xF.Name
'fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
Exit Function
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

---

Dave

Quote:

---

Originally Posted by Dave

Maybe trial using movefile to see if it's any quicker as well...

Code:

---

Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.moveFile xSPathStr & xF.Name, xDPathStr & xF.Name ', True
'remove original file
'Kill xSPathStr & xF.Name
'fso.deletefile (xSPathStr & xF.Name), False
sMoveFiles = True
Exit Function
End If
Next xF
Set xFS = Nothing
Set fso = Nothing
End Function

---

Dave

---

I'll give it a try this evening. Thanks

Quote:

---

Originally Posted by Xtremedesign

I'll give it a try this evening. Thanks

---

Working great, is there a way to capture the error "when the filename is not found " and past it into a cell?

Which code is working great? The file copy would be better... if U use move file then U have to first check to make sure the file doesn't already exist in the destination folder. Copyfile as coded replaces any existing file (ie. easier). Paste "the file not found" where? Dave

Quote:

---

Originally Posted by Dave

Which code is working great? The file copy would be better... if U use move file then U have to first check to make sure the file doesn't already exist in the destination folder. Copyfile as coded replaces any existing file (ie. easier). Paste "the file not found" where? Dave

---

The file is moving all the excel sheet correctly, would be nice if the error that say "file not found" the Filename not found could go next to the filename in a different cell. Easier to keep track of what filename was not moved.

I guess were going to go with copyfile then. Give this a trial. Dave

Code:

---

Option Explicit
Sub MoveFiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object, TempRange As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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 TempRange In xRg
If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
'MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
TempRange.Offset(0, 1) = "FILE DOESN'T EXIST!"
End If
Next TempRange
End Sub
Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
Kill xSPathStr & xF.Name
sMoveFiles = True
GoTo Below
End If
Next xF
Below:
Set xFS = Nothing
Set fso = Nothing
End Function

---

Quote:

---

Originally Posted by Dave

I guess were going to go with copyfile then. Give this a trial. Dave

Code:

---

Option Explicit
Sub MoveFiles()
'Updateby Extendoffice
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
Dim fso As Object, folder1 As Object, TempRange As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", 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 TempRange In xRg
If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
'MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
TempRange.Offset(0, 1) = "FILE DOESN'T EXIST!"
End If
Next TempRange
End Sub
Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set xFS = fso.GetFolder(xSPathStr)
For Each xF In xFS.Files
TempSplit = Split(xF.Name, "_")
If TempSplit(0) = CStr(xRg) Then
'copy source file to destination folder, overwrite file true/false
fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
'remove original file
Kill xSPathStr & xF.Name
sMoveFiles = True
GoTo Below
End If
Next xF
Below:
Set xFS = Nothing
Set fso = Nothing
End Function

---

---

This worked Perfectly. Thanks, I will donate to this site.

Did you guys ever hear of indentation ????

Code:

---

Sub M_start()
  M_snb "G:\OF\From\", "G:\OF\To\","abc"
End Sub

---

Code:

---

Sub M_snb(c00, c01, c02)
  c03= dir(c00 & c02 & "_*")
 
  do while c03<>""
    name  c00 & c03 As c01 & c03
    c03=Dir
  loop
End Sub

---

You are welcome Extremedesign and thanks for posting your outcome. snb I agree it would be nice to indent and fully comment all code. Your code certainly offers a simple solution to copying files to new locations but would require some adjustments to achieve the full outcome. I also hate using DIR after having some frustrating experience with the DIR function not finding files even though they clearly existed... so now I stick to the filesystem object. Anyways, as always, thanks for your input. Stay safe. Dave

Dave,

The code I posted doesn't copy, but moves files.
I never had any problems with 'Dir'.