This should do it...
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
Do U want to move more than 1 file at a time or just avoid this? Dave
That changes things a bit. Trial this. Dave
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
More new info which I hadn't considered. This should speed things up somewhat. Dave
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...
DaveFunction 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
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
I guess were going to go with copyfile then. Give this a trial. Dave
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
Did you guys ever hear of indentation ????
Sub M_start() M_snb "G:\OF\From\", "G:\OF\To\","abc" End SubSub 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'.