1819
05-29-2015, 07:39 AM
[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
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