I am creating an archiving system where I need to sort files into folders.
I create the folders automatically by mentioning the names of folder in an Excel sheet.
Now I need to copy the files with similar names in that respective folder.
E.g. A folder is created with the name "Ashley Davidson". All the files which are in one source folder and whose file name starts with Ashley Davidson should be copied to this folder.
There will be more than 500 folders and more than 10,000 files to be copied in these folders every week.
The code below creates the folders.
How can I copy the files based on similar name to these folders?
Important
The names of folders will be constant.
The start of the names of files will be similar but users add other words like date, age, sheet 1, sheet 2 etc., therefore List of Partial name concept will probably work here.
Examples of folder names
Example of file names
Code to create folders:
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
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
Set fso = CreateObject("Scripting.FileSystemObject") 'to check if file exists
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).
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 :)
Related
So, I renamed and moved some workbooks that are linked together and I need to update their xlExcelLinks on VBA, the thing is, I have a list of the references to update, but I can't figure out how to update only the ones I need and not every reference on the book.
The initial idea was to search for matching strings between a file name and the stored reference's path. Example data:
A2 Cell on Data.xlsx
Change to
I have this guide example code:
Sub Relink()
Dim previousFile, newFile, oldPath, newPath, Macro, altTab As String
'Macro stores the name of the file running the macro and altTab the name of the file to update
Dim ref as xlExcelLink 'Clearly not a type of data but I need something similar
Windows(Macro).activate
For I = 2 To 4
oldPath = Range("L"& I).Value
newPath = Range("M" & I).Value
previousFile = Range("N" & I).Value
newFile = Range("O" & I).Value
Windows(alTab).activate
'Somehow check for every reference avoiding itself
If ref.Address = oldPath & "\" & previousFile Then
ActiveWorkbook.ChangeLink Name:=oldPath & "\" & previousFile, _
NewName:=newPath & "\" & newFile, Type:=xlExcelLinks
End If
Next
End Sub
Note that on some files there could be only 1 update needed from 50ish references.
Try this code:
Sub UpdateLinks()
'Reference to your change list.
'ThisWorkbook is the file containing this code.
Dim ChangeList As Range
Set ChangeList = ThisWorkbook.Worksheets("Sheet2").Range("A2:D4")
'The workbook containing the links to change.
Dim wrkBk As Workbook
Set wrkBk = Workbooks("Test Timesheet.xlsx")
'If workbook isn't open use:
'Set wrkbk = workbooks.Open(<path to workbook>)
'Look at each link in the workbook.
'lnk must be Variant so it can be used in the For Each loop.
Dim lnk As Variant
For Each lnk In wrkBk.LinkSources
Dim OldPath As String
OldPath = Left(lnk, InStrRev(lnk, "\") - 1)
Dim OldFileName As String
OldFileName = Mid(lnk, InStrRev(lnk, "\") + 1, Len(lnk))
'Search for the existing path in first column of ChangeList.
Dim FoundLink As Range
Set FoundLink = ChangeList.Columns(1).Find(OldPath, , xlValues, xlWhole, xlByRows, xlNext)
'If it's not found, then continue to the next link.
'If it is found check that OldName also exists on that line, if it doesn't then continue searching.
If Not FoundLink Is Nothing Then
Dim firstAdd As String
firstAdd = FoundLink.Address
Do
If FoundLink.Offset(, 2) = OldFileName Then
'Found the link we're after so exit the loop.
Dim NewPath As String
NewPath = FoundLink.Offset(, 1)
Dim NewFileName As String
NewFileName = FoundLink.Offset(, 3)
Exit Do
Else
'Continue searching.
Set FoundLink = ChangeList.Columns(1).FindNext(FoundLink)
End If
Loop While firstAdd <> FoundLink.Address
'Make the change.
wrkBk.ChangeLink Name:=OldPath & Application.PathSeparator & OldFileName, _
NewName:=NewPath & Application.PathSeparator & NewFileName
End If
Next lnk
End Sub
I am working on a code which Moves the files after matching the file name into the folders accordingly "moveMatchedFilesInAppropriateFolders"
In order to run this code it is required that the Excel sheet should be saved in the same folder where the files and folders are available e.g. Folders and Files are saved in Drive E:\Archive. Therefore it is also important that the excel sheet should also be saved in the same folder (E:\Archive.
However i do not want to save the excel sheet in the same folder where the files and folders are placed and i wanted to save the excel sheet in some other Drive (e.g. Drive G). Is there any possibility where if i saved this excel sheet in other Drive and just give the path to it the code should run and not give error.
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 = "G:\!Archive Management\2023\" 'use here the path where the files can be found
Set FSO = CreateObject("Scripting.FileSystemObject") 'to check if file exists
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
firstly sorry if my english is not perfect as i'm french.
i'm new to this and i'm trying to make something work for my company to save some time.
i'd like to make a VBA code that Create a Folder with 9 sub folder inside but the tricky part i guess is that inside those 9 sub folders i need to have again sub folders.
i then need to auto copy an excel file to the main folder that have the same name
The Main folder name need to be based after 3 Excel row "A2" "C2" "B2"
Below a screenshot of inside the Main Folder :
I have some code that i found on the web that does some stuff that i need but i don't know how to do it.
Below code that i have :
Sub CreateDirs()
Dim r As Range
Dim RootFolder As String
RootFolder = Range("K2").Value
Range("A2").Select
For Each r In Range(Selection, Selection.End(xlDown))
If Len(r.Text) > 0 Then
On Error Resume Next
MkDir RootFolder & "\" & r.Text
MkDir RootFolder & "\" & r.Text & "\" & Range("L2").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L3").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L4").Value
On Error GoTo 0
End If
Next r
End Sub
combined with this code :
Sub File_Transfer()
'
Dim src As String, dst As String, fl As String
Dim lr As Long
'Source directory
'Range("A2").Select
lr = Cells(Rows.Count, "H").End(xlUp).Row
For X = 2 To lr
src = Range("F" & X).Value
'Destination directory
dst = Range("G" & X).Value
'Filename
fl = Range("E" & X).Value
On Error Resume Next
'get project id
FileCopy src & "\" & fl, dst & "\" & fl
If Err.Number <> 0 Then
End If
Next X
On Error GoTo 0
End Sub
Those 2 code will Create Folders with sub folders and will copy an excel file in the main folder but the Main folder is based only on one column
with this code i have this Excel Sheet :
I have this third code that will only create a Main Folder but with my name based on my 3 Column :
Sub ExampleCode()
Dim strName As String
Dim strCode As String
Dim strCode1 As String
Dim fName As String
Dim fPath As String
Dim lastRow As Long
Dim i As Long
Dim ws As Worksheet
'Where will we create these folders?
fPath = "C:\Users\WBRICET\Documents\TESTVBA"
'Error check
If Right(fPath, 1) <> Application.PathSeparator Then
fPath = fPath & Application.PathSeparator
End If
'What sheet has the data?
Set ws = ActiveSheet
Application.ScreenUpdating = False
With ws
'How much data do we have
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop from row 3 to end
For i = 3 To lastRow
'Get the bits
strName = .Cells(i, "A").Value
strCode = .Cells(i, "C").Value
strCode1 = .Cells(i, "B").Value
'Build folder name
fName = strName & " " & strCode & " " & strCode1
'Check if folder already exists
If Dir(fPath & fName, vbDirectory) = "" Then
'Create folder
MkDir fPath & fName
End If
Next i
End With
Application.ScreenUpdating = True
'Since nothing changed on sheet, provide feedback to user
MsgBox "Done!"
End Sub
Sorry for my long post but that would help me a lot in my work and my coworker too.
Thanks again :)
EDIT : if it's easier for the subfolders part could we not do something that copy existing exemple empty folders to the new one created ?
Like The VBA will Create a Folder based on 3 Column "XXX XXX XXX" copy the excel in main folder and also copy empty entire Subfolder "shell" that i normaly copy by hand"
I appreciate all the help with my last question previous post
Previous code to find file name based on cell contents. Perhaps it can be edited slightly to work for this new request?
Sub ParseFiles()
Dim sh As Worksheet, lastRow As Long, i As Long
Const foldPath As String = "C:\Users\User1\Downloads\Test*"
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
sh.Range("B" & i).Value = GetFilePath(foldPath, sh.Range("A" & i).Value)
Next
End Sub
Function GetFilePath(dirFolder As String, strToFind As String) As String
GetFilePath = Dir(dirFolder & "*" & strToFind & "*.*")
End Function
I would like to find if a folder exists in a directory, which is likely within a subfolder of that directory. The folder name may have characters in front or behind and won't match the cell value perfectly, but it will contain the cell value. Example:
Folder name is 'customer 601892 20220105' but the cell value is '601892'
Here we have a directory (Test) where I'm searching if a folder name exists based on the contents of A1, A2, etc... if it exists, I'd like the output in B1, B2 with the folder path and folder name.
This is the ideal output.
Please, try the next way. Since you cannot use Dir in two different loops, in the Sub I will use "Scripting.FileSystemObject", to iterate between the main folder subfolders:
Sub extractSubfolderPathFromSubfolders()
Dim sh As Worksheet, lastRow As Long, i As Long, fldName As String
Dim FSO As Object, fld As Object, subFld As Object
Const foldPath As String = "C:\Users\User1\Downloads\Test\"
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(foldPath)
For i = 2 To lastRow
For Each subFld In fld.SubFolders
fldName = getFoldPath(CStr(subFld), sh.Range("A" & i).value)
If fldName <> "" Then
sh.Range("B" & i).value = subFld & "\" & fldName
End If
Next
Next i
End Sub
And a function able to return a directory knowing its partial name. It is called by the above sub:
Function getFoldPath(dirFolder As String, strToFind As String) As String
Dim fldName As String
If Right(dirFolder, 1) <> "\" Then dirFolder = dirFolder & "\"
fldName = Dir(dirFolder & "*" & strToFind & "*", vbDirectory)
Do While fldName <> ""
If fldName <> "." And fldName <> ".." Then
' Use bitwise comparison to make sure dirFolder is a directory.
If (GetAttr(dirFolder & fldName) And vbDirectory) = vbDirectory Then
getFoldPath = fldName: Exit Function
End If
End If
fldName = Dir
Loop
End Function
I need to close my computer now. If something does not work as you need, please try explaining why. I will adapt the code tomorrow...
I have to search and copy a number of files in a folder starting from an Excel list like:
8100 ' cell "A2"
8152 ' cell "A3"
8153 ' cell "A4"
in the source folders there are files named like this:
8153.pdf
100_8152.pdf
102_8153.pdf
8153 (2).pdf
How can I find these files and copy ALL the files that matches in a separate folder? The code returns only one file, but I need ALL the files matching the cell value. I need to extend my research in subfolders organized by years too (ie: "D:\myfolder\2015", "D:\myfolder\2016", etc.).
Thanks to user3598756, I'm now using this code:
Option Explicit
Sub cerca()
Dim T As Variant
Dim D As Variant
T = VBA.Format(VBA.Time, "hh.mm.ss")
D = VBA.Format(VBA.Date, "yyyy.MM.dd")
Dim Source As String
Dim Dest As String
Dim Missed As String
Dim fileFound As String
Dim CodiceCS As Variant
Dim cell As Range
Source = "D:\myfolder\"
Dest = "D:\myfolder\research " & D & " " & T
If Dir(Dest, vbDirectory) = "" Then MkDir Dest '<--| create destination folder if not alerady there
With Worksheets("Cerca") '<-- reference your worksheet with pdf names
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- loop through its column "A" cells with "constant" (i.e. not resulting from formulas) values from row 2 down to last non empty one
CodiceCS = VBA.Left((cell.Value), 4)
fileFound = Dir(Source & "\" & CodiceCS & "\*" & cell.Value & "*.Pdf") '<-- look for a source folder file whose name contains the current cell value
If fileFound <> "" Then '<-- if found...
FileCopy Source & "\" & CodiceCS & "\" & fileFound, Dest & "\" & fileFound '<-- ...copy to destination folder
Else '<--otherwise...
Missed = Missed & cell.Value & vbCrLf '<--... update missing files list
End If
Next cell
End With
If Missed <> "" Then '<-- if there's any missing file
Dim FF As Long
FF = FreeFile
Open (Dest & "\" & "MissingFiles.txt") For Output As #FF
Write #FF, VBA.Left(Missed, Len(Missed) - 2)
Close #FF
End If
MsgBox "OK"
Shell "explorer.exe " + Dest, vbNormalFocus
End Sub
This code will place all the file names in the main folder and subfolders into an array. It then looks through the array for matching values.
I've included an extra couple of lines which I've commented out - these are different options you could do within the code.
Public Sub cerca()
Dim DT As String
Dim Source As String
Dim Dest As String
Dim vFiles As Variant
Dim vFile As Variant
Dim rCell As Range
Dim oFSO As Object
Dim FileFound As Boolean
Dim FF As Long
FF = FreeFile
DT = Format(Now, "yyyy.mm.dd hh.mm.ss")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Source = "D:\myfolder\"
Dest = "D:\myfolder\research " & DT
If Dir(Dest, vbDirectory) = "" Then MkDir Dest
'Get the full path name of all PDF files in the source folder and subfolders.
vFiles = EnumerateFiles(Source, "pdf")
With Worksheets("Cerca")
'Look at each cell containing file names.
For Each rCell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
FileFound = False 'Assume the file hasn't been found.
'Check each value in the array of files.
For Each vFile In vFiles
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Use this line if the file name in the sheet exactly match the file name in the array. '
'8152 and 100_8152.pdf are not a match, 8152 and 8152.pdf are a match. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If rCell & ".pdf" = FileNameOnly(vFile) Then
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Use this line if the file name in the sheet should appear in the file name in the array. '
'8152 and 100_8152.pdf are a match, 1852 and 8152.pdf are a match. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If InStr(FileNameOnly(vFile), rCell.Value) > 0 Then
'If found copy the file over and indicate it was found.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This line will use the rcell value to name the file. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
oFSO.CopyFile vFile, Dest & "\" & rCell & ".pdf"
''''''''''''''''''''''''''''''''''''''
'This line will not rename the file. '
''''''''''''''''''''''''''''''''''''''
'oFSO.CopyFile vFile, Dest & "\" & FileNameOnly(vFile)
FileFound = True
End If
Next vFile
'Any file names that aren't found are appended to the text file.
If Not FileFound Then
Open (Dest & "\" & "MissingFiles.txt") For Append As #FF ' creates the file if it doesn't exist
Print #FF, rCell ' write information at the end of the text file
Close #FF
End If
Next rCell
End With
End Sub
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
Public Function FileNameOnly(ByVal FileNameAndPath As String) As String
FileNameOnly = Mid(FileNameAndPath, InStrRev(FileNameAndPath, "\") + 1, Len(FileNameAndPath))
End Function