Help on Moving file to another folder, using partial filename

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'.