Adapt code to move files to a subfolder of the same name

[1819]

[No replies when posted at excelforum.com, so now moved to here]

The code shown below copies files with matching names in the folder entered in cell B1 to any specified lowest tier subfolder of that name in column A.

So "mickey mouse.xls" will be copied to C:\Users\Mickey\Mickey Mouse (if that folder is in column A).

Can the code please be adapted to

1) move, not copy, the original file
2) have the option of only matching the final word in the subfolder name. So this would mean "minnie mouse.xls" would move to "C:\Users\Mickey\Mickey Mouse" because the word Mouse (anywhere in the file name) matches the final word in the subfolder name. I'd be happy to have this as a separate macro if it's too complicated to offer the choice.

Many thanks.

Sub CopyFilesToMatchingSubfolders()
'--for each filepath in a list, get the lowest subfolder name
'     which will act as a search keyword.
'  searches a specified source folder for files containing keywords
'  copies files containing keyword to that subfolder
'  a file will only be copied to first folder on list matching keyword
 
'--requires reference to Microsoft Scripting Runtime library
 
 Dim dctFilesCopied As Scripting.Dictionary
 Dim lLastRow As Long, lCountCopied As Long
 Dim sSrcFolder As String, sTgtFolder As String
 Dim sKeyword As String, sFilename As String, sErrMsg As String
 Dim c As Range, rFilePaths As Range

 On Error GoTo ErrProc
 
 With ActiveSheet 'read inputs-modify to match actual range addresses
   sSrcFolder = .Range("B1").Value ' c:\test\source\
   '--add trailing "\" if none
   If Right(sSrcFolder, 1) <> "\" Then sSrcFolder = sSrcFolder & "\"
   
   '--read list of filepaths beginning at A2
   lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   If lLastRow < 2 Then
      MsgBox "No filepaths found."
      GoTo ExitProc
   End If
   
   Set rFilePaths = .Range("A2:A" & lLastRow)
 End With
 
 '--store copied filenames in dictionary
 Set dctFilesCopied = New Scripting.Dictionary
 
 For Each c In rFilePaths
   sTgtFolder = c.Value
   '--add trailing "\" if none
   If Right(sTgtFolder, 1) <> "\" Then sTgtFolder = sTgtFolder & "\"
   sKeyword = getKeyword(sPath:=sTgtFolder)
   sFilename = Dir(sSrcFolder & "*" & sKeyword & "*")

   While sFilename <> ""
      '--check if file already copied
      If Not dctFilesCopied.Exists(sFilename) Then
         dctFilesCopied.Add sFilename, 1
         '--copy file to target
         FileCopy sSrcFolder & sFilename, sTgtFolder & sFilename
         lCountCopied = lCountCopied + 1
      End If
      sFilename = Dir()
   Wend
 Next c

 MsgBox lCountCopied & " files were copied.", vbInformation, "Done"
 
ExitProc:
 On Error Resume Next
 Set dctFilesCopied = Nothing
 If Len(sErrMsg) > 0 Then MsgBox sErrMsg
 Exit Sub
 
ErrProc:
 sErrMsg = Err.Number & " - " & Err.Description
 Select Case sErrMsg
   Case "76 - Path not found"
      sErrMsg = "Target Path: " & sTgtFolder & " not found."
   Case Else
 End Select
 Resume ExitProc
End Sub

Private Function getKeyword(sPath As String) As String
'--returns keyword by extracting lowest subfolder name from folder path
'  "c:\MyFolder\MySubfolder\" returns "MySubfolder"
'  "c:\MyFolder\MySubfolder" returns "MySubfolder"
'  "" returns ""

 Dim vSplit As Variant
 '--add trailing "\" if none
 If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 '--extract lowest subfolder name
 vSplit = Split(sPath, "\")
 getKeyword = vSplit(UBound(vSplit) - 1)
 
End Function

[Kenneth Hobs]

(1) Replace FileCopy with Name.
(2) You should use the FSO method to see if the folder exists. If not, do your getKeyword routine but modified. You could do all of this part in that routine possible or just add an Optional parameter or write two routines to take the first index element of the split array or take the last. The first is the lbound and the last if the ubound when you split the folder name by a space character.

[1819]

(2) You should use the FSO method to see if the folder exists. If not, do your getKeyword routine but modified. You could do all of this part in that routine possible or just add an Optional parameter or write two routines to take the first index element of the split array or take the last. The first is the lbound and the last if the ubound when you split the folder name by a space character.

Many thanks, Kenneth. My VBA is not quite good enough. Please could you get me past first base in terms of coding this? Would be much appreciated.

[1819]

As there has been no further contact here, the question has been transferred to http://www.mrexcel.com/forum/excel-q...ml#post4173688.

The question here is closed.