View Full Version : [SOLVED:] Help on Moving file to another folder, using partial filename
Xtremedesign
04-03-2020, 01:31 AM
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
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.Coun t = 0) Then
RmDir xStr
End If
Next
End Sub
Paul_Hossler
04-03-2020, 03:37 AM
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
Xtremedesign
04-03-2020, 04:02 AM
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...
Dim TempSplit As Variant
TempSplit = Split(xSPathStr, "_")
xSPathStr= TempSplit(0)
Call sMoveFiles(Xrg, xSPathStr, xDPathStr)
HTH. Dave
Xtremedesign
04-03-2020, 07:52 AM
Where would I place the 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...
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
Xtremedesign
04-03-2020, 09:17 AM
I will test the code now. Thanks
Xtremedesign
04-03-2020, 10:08 AM
26272
The code is not going through the codes. Its stopping at the yellow break point. Its reading the source folder and destination folder
Xtremedesign
04-03-2020, 10:57 AM
After reviewing this again, I'm not that certain that code will help. It may be better to do this...
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
26273
Seem it's not seeing the .CVS files in the folder. I am still new at this stuff.
TempSplit = Split(CSTR(xVal)), "_")
Change that for now. What is the actual problem? RU creating bad file names and trying to fix them? Dave
Xtremedesign
04-03-2020, 12:15 PM
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.
Xtremedesign
04-03-2020, 12:45 PM
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.
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"
Xtremedesign
04-03-2020, 02:11 PM
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
Xtremedesign
04-03-2020, 04:23 PM
" 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
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
Xtremedesign
04-04-2020, 08:45 AM
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
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
Xtremedesign
04-04-2020, 01:00 PM
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
Xtremedesign
04-04-2020, 01:59 PM
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...
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
Xtremedesign
04-04-2020, 02:47 PM
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
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
Xtremedesign
04-04-2020, 03:14 PM
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
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
Xtremedesign
04-04-2020, 06:42 PM
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
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
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...
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
Xtremedesign
04-05-2020, 06:33 AM
Maybe trial using movefile to see if it's any quicker as well...
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
Xtremedesign
04-05-2020, 03:13 PM
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
Xtremedesign
04-05-2020, 05:02 PM
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
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
Xtremedesign
04-06-2020, 01:34 PM
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
This worked Perfectly. Thanks, I will donate to this site.
Did you guys ever hear of indentation ????
Sub M_start()
M_snb "G:\OF\From\", "G:\OF\To\","abc"
End Sub
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'.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.