I am working to create automatic Archiving system where i need to automatically sort the files folder wise. I am now able to create the folders automatically by mentioning the names of folder in excel sheet. Now i only need to copy the files with the similar names in that respective folder. E.g. A folder is created with the name "Ashley Davidson", now all the files which are in one source folder and whose file names are starting with Ashley Davidson should get copy in this folder.
Altogether there will be more than 500 folders which will be created and more than 10,000 files which needs to be copied in these folders every week.
From the code mentioned below i can create automatic folders. Can anyone help and can provide a code which can copy the files based on similar name in these folders.
Important points are The names of Folders which i will mention in Excel sheet will be constant. however the starting names of Files will be similar but users add other words like date, age, sheet 1, sheet 2 etc. in file names too therefore Maybe List of Partial name concept will probably work here
for examples please see print shots.
and example of file names
the code i have to create automatic folders is mentioned below
Sub MakeFolders()
Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A2:A" & lastR).Value2
rootPath = ThisWorkbook.Path & "\"
For i = 1 To UBound(arr)
If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
MkDir rootPath & arr(i, 1)
End If
Else
MsgBox "Illegals characters or empty cell (" & sh.Range("A" & i 1).Address & ")..."
End If
Next i
End Sub
Function noIllegalChars(x As String) As Boolean
Const illCh As String = "*[\/\\"":\*?]*"
If Not x Like illCh Then noIllegalChars = True
End Function
I will really be thankful
CodePudding user response：
My code works from having the new Folders in the same folder as the workbook you've created said folders from (as it is in your code) and the files to be copied were in a seperate folder in the same path as your workbook; I found that easier to work with since then the only files in that folder are files to be copied, not extra folders within.
Sub copyFilesToFolder()
Dim lRow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ccell As Range
Dim fsO As Object, oFolder As Object, oFile As Object
Dim pathFiles As String, sFolderPath As String, sSource As String, sDestination As String
Set wb = ActiveWorkbook
Set ws = wb.ActiveWorksheet
lRow = Range("A" & Rows.Count).End(xlUp).Row
pathFiles = "Q:\WHERE YOUR ORIGINAL WORKBOOK IS\Test\" 'could be gotten from wb technically
Set fsO = CreateObject("Scripting.FileSystemObject")
Set oFolder = fsO.GetFolder(pathFiles)
For Each oFile In oFolder.Files 'go through all the files
For Each ccell In Range("A2:A" & lRow).Cells 'go through all the folder-names
'Debug.Print ccell.Value2
'Debug.Print oFile.Name
If InStr(oFile.Name, ccell.Value2) > 0 Then 'if folder name is in file name
sFolderPath = wb.Path & "\" & ccell.Value2 & "\"
If Dir(sFolderPath, vbDirectory) <> "" Then 'if Folder exists
sDestination = sFolderPath & oFile.Name
If Dir(sDestination) = "" Then 'file doesn't exist yet
sSource = pathFiles & oFile.Name
'Debug.Print sSource
'Debug.Print sDestination
Call fsO.CopyFile(pathFiles & oFile.Name, sFolderPath & oFile.Name)
GoTo Skip
End If
Else
MsgBox ("Folder " & ccell.Value2 & " doesn't exist yet")
End If
End If
Next ccell
Skip:
Next oFile
End Sub
Hope this helps :)
CodePudding user response：
You did not answer the clarification question and I need to leave my office. The next code assumes that all files exist in a common folder and they should be moved in the folder exactly named as the string in column A:A of the active sheet. It is able to move or copy the file, according to the line you should uncomment:
Sub moveMatchedFilesInAppropriateFolders()
Dim sh As Worksheet, lastR As Long, filesPath As String, fileName As String, foldersRoot As String, folderPath As String
Dim arr, boolNotFound As Boolean, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).Value2
foldersRoot = ThisWorkbook.Path & "\" 'use here the root folder for folders
filesPath = "your files to be processed folder" 'use here the path where the files can be found
For i = 1 To UBound(arr)
boolNotFound = False
If Dir(foldersRoot & arr(i, 1), vbDirectory) <> "" Then
folderPath = foldersRoot & arr(i, 1) & "\"
Else
MsgBox arr(i, 1) & " folder could not be found!" & vbCrLf & _
"Please, note and correct it after copying the matching ones and run the code again!"
boolNotFound = True
End If
If Not boolNotFound Then
fileName = Dir(filesPath & arr(i, 1) & "*.*")
Do While fileName <> ""
If Not fso.FileExists(folderPath & fileName) Then 'move/copy only if it does not exist in destination fld
'uncomment the way you need (moving or copying):
'Name filesPath & fileName As folderPath & fileName 'the file is moved
'FileCopy filesPath & fileName, folderPath & fileName 'the file is copied
End If
fileName = Dir
Loop
End If
Next i
End Sub
Not tested, but it should work.
If you need something else, please better answer my last clarifications question.
Besides all that, I think it would be good to place a marker in B:B column, for not found folders, if any. In this way, the code can be adapted that at the next run to only run the ones having the marker (and delete it, if the string has been corrected and the folder has been found).