Help on Moving file to another folder, using partial filename

[Xtremedesign]

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]

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]

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

[Dave]

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]

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

[Dave]

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]

I will test the code now. Thanks

[Xtremedesign]

image002.jpg

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

[Xtremedesign]

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

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

[Dave]

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]

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]

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

[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"

[Xtremedesign]

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

[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

[Xtremedesign]

" 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

[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

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]

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]

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

[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