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
Related
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 :)
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 am using VBA to search a network folder with typically about 4000 .txt files and move the bad ones that contain strings listed in an excel range, to another folder. Remaining good files are zipped and moved/scattered and the .txt's moved to a single folder.
Here is my code that takes many hours to run, probably due to the double looping. Please help me with changing this to run faster/more efficient.
Option Compare Text
Sub SDRFiles()
Dim lastRow As Integer
Dim Fldr As Object
Dim BaseFldr As String
Dim sdrDNU As String
Dim sdrDateFldr As String
Dim fDate
Dim FSO As Object
Dim FirstTwo As String
Dim NineTen As String
Dim Lead As String
Dim BadFile As Integer
Dim sdrFile As String
Dim fldExists As String
'Process SDR files. Move files off landing zone to working folder, pull out and store bad files,
'zip good files and move to each owner's folder, save good txt in Data Czar's folder.
'Landing zone
BaseFldr = "\\nasgw013pn\hedis_prod\SDR FILES"
'new SDR folder for files
fDate = Format(Date, "mmddyyyy")
'Processing fldr
sdrDateFldr = BaseFldr & "\" & fDate & "_" & shControl.cboMonth.Value & theCycle
fldExists = Dir(sdrDateFldr)
If fldExists = "" Then
MkDir sdrDateFldr
End If
'Move all files from landing zone to processing folder
Set FSO = CreateObject("scripting.filesystemobject")
extn = "\*.txt"
FSO.MoveFile Source:=BaseFldr & extn, Destination:=sdrDateFldr & "\"
'Do Not Use sub folder for bad files
sdrDNU = sdrDateFldr & "\DNU"
fldExists = Dir(sdrDNU)
If fldExists = "" Then
MkDir sdrDNU
End If
'Good Text File destination
TextFileFldr = fDate & "_" & shControl.cboMonth.Value & theCycle & "_txt"
TextFileDest = sdrDateFldr & "\" & TextFileFldr
fldExists = Dir(TextFileDest)
If fldExists = "" Then
MkDir TextFileDest
End If
'Bottom of bad file strings
lastRow = shSDR.Range("A" & Rows.Count).End(xlUp).Row
Set xFolder = FSO.GetFolder(sdrDateFldr)
'loop thru folder
For Each xFile In xFolder.Files 'About 4000 files. can vary
Fname = xFile.Name
FirstTwo = Left(Fname, 2)
NineTen = Mid(Fname, 9, 2)
Lead = Mid(Fname, 16, 2)
'range with list of bad strings
For Each Item In shSDR.Range("A2:A" & lastRow) 'about 10 strings. can vary
'Hold file from 1st loop and test. If bad file, move to Do Not Use (DNU) folder
If InStr(Fname, Item) > 0 Or _
(InStr(Fname, "PWOEY") > 0 And FirstTwo <> "OH") Or _
(InStr(Fname, "HNARST") > 0 And FirstTwo <> NineTen) Or _
(InStr(Fname, "FTANDHEIPANE") > 0 And FirstTwo <> Lead) Then
'bad file - move to DNU Folder
Name sdrDateFldr & "\" & Fname As sdrDNU & "\" & Fname
'Bad file indentified
BadFile = 1
'exit this loop if matched and get next file
Exit For
End If
Next Item
If BadFile = 0 Then
'Good file - zip it and move each txt file to same folder
Call Zipp(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), sdrDateFldr & "\" & Fname)
‘move good zipped file to its own specific folder – NY folder, FL folder TX folder etc.
Call MoveIt(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), Replace(Fname, "txt", "zip"))
End If
BadFile = 0
Next xFile
End Sub
'says function but it really a sub
Public Function Zipp(ZipName, FileToZip)
'Called by all modules to create a Zip File
‘Dim FSO As Object
Dim oApp As Object
If Len(Dir(ZipName)) > 0 Then Kill (ZipName)
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
dFile = Dir(FileToZip)
On Error Resume Next
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(CVar(ZipName)).CopyHere CVar(FileToZip)
DoEvents
'====HELP!!! ================Please help me with the following. It hangs sporadically, sometimes at
'============================file 200 or may the 1500th file. I have to esc esc and continue.
'============================For 10 to 20 files it seems to run fine
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CVar(ZipName)).Items.Count = 1
Application.Wait (Now + TimeValue("0:00:06"))
DoEvents
Loop
'=============================================================================
'=============================================================================
'USED ONLY BY Sub SDRFiles()
'THIS PART OF ZIPP SAVES THE .TXT FILE TO DATA CZAR'S FOLDER
'SDR Processing - Move text file
If SDR = "Y" And Len(Dir(FileToZip)) > 0 Then
SetAttr FileToZip, vbNormal
Name FileToZip As TextFileDest & "\" & dFile
End If
Set oApp = Nothing
‘Set FSO = Nothing
End Function
Sub MoveIt(PathZip, ZipFileName)
Dim rootPlusSubFolder As String
Dim NasState As Range
Dim NasLocation As String
Dim FSO As Object
'MOVE ZIPP FILES TO FOLDERS
'MOVE FILES TO IMP FOLDER - find state in extract name and MOVE file to that folder
'Bottom of state list
botRow = shNasMoves.Cells(shNasMoves.Rows.Count, 7).End(xlUp).Row
'Bottom of list of import folder names
NasBot = Sheets("NASMoves").Cells(Rows.Count, "A").End(xlUp).Address
'Look up state to get import folder path
Application.FindFormat.Clear
Set NasState = shNasMoves.Range("A1:" & NasBot).Find(What:=Left(ZipFileName, 2))
'if state found, get folder location URL
If Not NasState Is Nothing Then
NasLocation = NasState.Offset(0, 1).Value
'current month for sub folder file name
CurMonthFolder = "CS_" & theMo & "_" & theCycle & "\"
'Combined destination folder and sub folder name
rootPlusSubFolder = NasLocation & CurMonthFolder
Set FSO = CreateObject("scripting.filesystemobject")
'if CS Import SUB folder doesn't exist, create it - sometimes DIR sometimes FSO
If Not FSO.FolderExists(rootPlusSubFolder) Then
FSO.CreateFolder (rootPlusSubFolder)
End If
'Final dest Fldr
If Not FSO.FolderExists(rootPlusSubFolder & "\" & "SDR") Then
FSO.CreateFolder (rootPlusSubFolder & "\" & "SDR")
End If
'try to stop pop up
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
'Debug.Print rootPlusSubFolder & "SDR"
On Error Resume Next
'move file from Root to destination folder/sub folder
FSO.MoveFile PathZip, rootPlusSubFolder & "SDR\" & ZipFileName
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End If
End Sub
So basically, I need to transfer pdf file from one folder to another. But the source folder contains thousands of pdfs and i need to transfer about 500+ of them in another folder which I should create as well. So it means, I copy "apple" from source then in the destination folder, I'll create a folder named "apple" then paste the copied "apple" file in the created "apple" folder.
Sub transferpdf()
Application.ScreenUpdating = False
Sheets("Stress Log").Activate
r = 3
'Declare Variables
'Do While Cells(r, 3) <> ""
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Dim foldname As String
Call create_folder
'Name of new folder
'foldname = Cells(r, 1)
'File name to copy
sFile = Cells(r, 3) & "_R" & Cells(r, 4) & ".pdf"
'Source file path
sSFolder = "\\Fdnet.com\ca_projects\CA_LNGC\000_GENERAL\TRANSFER\TO CSA_From Stress - PERMANENT\"
'Destination file path
sDFolder = "C:\Users\vid14865\Desktop\VLM - Sir Earl\3RC430BB VLM - Stress ISOs\" & foldname
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
MsgBox [sFile] & " Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
FSO.CopyFile (sSFolder & sFile), sDFolder, True
MsgBox [sFile] & (" Copied Successfully")
Else
MsgBox [sFile] & " Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
'r = r + 1
'Loop
MsgBox "Finished Creating"
End Sub
Sub create_folder()
Sheets("Stress Log").Activate
r = 3
foldname = Cells(r, 1)
MkDir ("C:\Users\vid14865\Desktop\VLM - Sir Earl\3RC430BB VLM - Stress ISOs\" & foldname)
End Sub
This is what I have so far. This creates the folder and copies the file very well, but then the file is not copied in the folder. It's copied outside the created file.
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