Unable to search/loop through subfolders - vba

Can any one help why I can't pickup file from sub-folders?
My code will locate locate and attach the file to an email if the file is in the main folder, but not if the file is located in sub-folders.
Code Sample:
Set obMail = Outlook.CreateItem(olMailItem)
With obMail
.to = "email#comapny.com"
.Subject = "O/S Blanace"
.BodyFormat = olFormatPlain
.Body = "Please see attached files"
iRow = 24 'initialize row index from 24
Do While Cells(iRow, 1) <> Empty
'picking up file name from column A
pFile = Dir(dPath & "\*" & Cells(iRow, 1) & "*")
'checking for file exist in a folder and if its a pdf file
If pFile <> "" And Right(pFile, 3) = "pdf" Then
.Attachments.Add (dPath & "\" & pFile)
End If
'go to next file listed on the A column
iRow = iRow + 1
Loop
.Send
End With

The Dir function doesn't traverse subfolders. It traverses the path you give it, not the tree structure. It also resets when called so calling recursively is not an option.
So if you pass it "C:\Test\" you can use it to traverse Test; if cell contains "C:\Test\NextTest\", you can use it to iterate over NextTest.
What you can do is use a Collection to hold each directory and explore recursively in that way.
For an example of how to do this see the following from How To Traverse Subdirectories with Dir
Sub TraversePath(path As String)
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
currentPath = Dir(path, vbDirectory)
'Explore current directory
Do Until currentPath = vbNullString
Debug.Print currentPath
If Left(currentPath, 1) <> "." And _
(GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currentPath
End If
currentPath = Dir()
Loop
'Explore subsequent directories
For Each directory In dirCollection
Debug.Print "---SubDirectory: " & directory & "---"
TraversePath path & directory & "\"
Next directory
End Sub
Sub Test()
TraversePath "C:\Root\"
End Sub
You can easily adapt this to suit your purposes.

Related

Delete files in a folder that are not found in Excel Spreadsheet

I developed a code that loops through files and folders' names found in an Excel Spreadsheet, finds them in a folder and deletes them.
The problem is that there are some files and folders that don't appear on the spreadsheet, but still need to be deleted.
My goal is to have more free space.
Someone suggested i copied the folder list into another column, match the file names and then delete the ones that don't match.
I'd prefer automation, though.
Any suggestions?
Thanks in advance!
Code:
Sub DeleteSpecificFilesAndFolders()
'This module deletes Extracted Files folders, Flat Files folders and Final Flat Files (.txt format)
Const path = "C:\Users\N\Desktop\Kill_function_test\Test folder for deleting\"
Dim r As Range
Dim r2 As Range
Dim folderpath As String
Dim folderpath_1 As String
Dim fso As FileSystemObject
Set fso = New Scripting.FileSystemObject
Set r2 = Cells(2, 1)
Do Until r2 = ""
folderpath = path & r2 & "\" & "Extracted Files"
'Checks if the folder exists and then deletes it.
If fso.FolderExists(folderpath) Then
fso.DeleteFolder (folderpath)
End If
'Checks if the folder exists and then deletes it
folderpath_1 = path & r2 & "\" & "Flat Files"
If fso.FolderExists(folderpath_1) Then
fso.DeleteFolder (folderpath_1)
End If
Set r2 = r2.Offset(1, 0)
DoEvents
Loop
'Loops through and deletes the "INACTIVE" Final Flat Files (.txt)
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.Value) = "INACTIVE" Then
'Checks if the extracted flat file exists.
If Dir(path & r.Offset(0, -4) & "\" & "Final Flat Files" & "\" & r.Offset(0, 1) & ".txt") <> "" Then
Kill path & r.Offset(0, -4) & "\" & "Final Flat Files" & "\" & r.Offset(0, 1) & ".txt"
End If
End If
Set r = r.Offset(1, 0)
Loop
End Sub
Try the code below. I used the Dir() command/function. This allows you to obtain all the folder/files that exists in a path.
Sub DeleteSpecificFilesAndFolders()
'This module deletes Extracted Files folders, Flat Files folders and Final Flat Files (.txt format)
Const path = "C:\Users\N\Desktop\Kill_function_test\Test folder for deleting\"
Dim r As Range
Dim folderpath As String
Dim folderpath_1 As String
Dim FolderName As String
Dim fso As FileSystemObject
Set fso = New Scripting.FileSystemObject
FolderName=Dir(Path & "*", vbDirectory)
While FolderName <> ""
if Not FolderName like "*.*" then 'This is because when using Dir(,vbdirectory) you can get . and .. or if files exist
folderpath = path & FolderName & "\" & "Extracted Files"
'Checks if the folder exists and then deletes it.
If fso.FolderExists(folderpath) Then
fso.DeleteFolder (folderpath)
End If
'Checks if the folder exists and then deletes it
folderpath_1 = path & FolderName & "\" & "Flat Files"
If fso.FolderExists(folderpath_1) Then
fso.DeleteFolder (folderpath_1)
End If
end if
FolderName=Dir() 'This will set FolderName to the next folder
DoEvents
wend
'Loops through and deletes the "INACTIVE" Final Flat Files (.txt)
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.Value) = "INACTIVE" Then
'Checks if the extracted flat file exists.
If Dir(path & r.Offset(0, -4) & "\" & "Final Flat Files" & "\" & r.Offset(0, 1) & ".txt") <> "" Then
Kill path & r.Offset(0, -4) & "\" & "Final Flat Files" & "\" & r.Offset(0, 1) & ".txt"
End If
End If
Set r = r.Offset(1, 0)
Loop
End Sub
Hope this helps

Checking if a file is already saved in a different folder

Dears I have this piece of code that checks if a file .xls in a target folder is already saved under format .xlsb in the ActiveWorkbook folder. this works properly for the first file but the loop stops after that and doesn't checks the remaining ones.
myFile = Dir(myPath & myExtension)
'check if the file .xls is in the current folder in format .xlsb
Do While myFile <> ""
If Dir(Application.ActiveWorkbook.Path & "\" & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
'next file
myFile = Dir
Loop
You haven't created an array for looping the files from. Below is the code for checking file existance
Sub checkExistance()
'setup
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("Your Folder Path Here")
'file
Dim myFile As String
Dim FileName As String
Dim FileExtension As String
FileName = "Your File Name"
FileExtension = ".xls"
myFile = FileName & FileExtension
'Loop through each file in folder
For Each objFile In objFolder.Files
If objFile.Name = Replace(myFile, ".xls", ".xlsb") Then
MsgBox objFile.Name & " Ci sta"
Else
MsgBox objFile.Name & " Nun Ci sta"
End If
Next
End Sub
There is a function on another answer HERE that returns an array of files within a folder. If you grab that, you can get what you need with:
Dim myFile As Variant
Dim folder_containing_xls As String
Dim folder_containing_xlsb As String
folder_containing_xls = "FOLDER PATH HERE"
folder_containing_xlsb = Application.ActiveWorkbook.Path 'or "OTHER OR SAME FOLDER PATH HERE"
If Right(folder_containing_xls, 1) <> "\" Then folder_containing_xls = folder_containing_xls & "\"
If Right(folder_containing_xlsb, 1) <> "\" Then folder_containing_xlsb = folder_containing_xlsb & "\"
For Each myFile In listfiles(folder_containing_xls)
If myFile Like "*.xls" Then
If Dir(folder_containing_xlsb & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
End If
Next
I couldn't work out if you were looking for both files to be in the same folder, or if they were in different folders, so I've built it to cope with either.

VBA - Do While Loop returns Dir <Invalid procedure call or argument>

I am running a loop through a folder in order to get the complete filename address (folders address + file name and extension).
I am using the following, but at some point the Dir value is <Invalid procedure call or argument>
recsFolder = Functions.GetFolder("C:\")
recfile = recsFolder & "\" & Dir(recsFolder & "\*.rec*")
Do While Len(recfile) > 0
recfile = recsFolder & "\" & Dir
Loop
The error is thrown before the loop as completed reading all the files.
EDIT: another approach and Dir is changing everytime I press F8
If Right(recsFolder, 1) <> "\" Then recsFolder = recsFolder & "\"
numFiles = 0
recfile = Dir(recsFolder)
While recfile <> ""
numFiles = numFiles + 1
recfile = Dir()
Wend
I am trying this latest approach and I get the same error. The problem is that when I run the code line by line (F8) I can see that the Dir value changes everytime a new line of code is run inside the While.
Instead of DIR, how about this:
' enable Tools->References, Microsoft Scripting Runtime
Sub Test()
Dim fso As New Scripting.FileSystemObject
Dim fldr As Folder
Set fldr = fso.GetFolder("C:\test")
HandleFolder fldr
End Sub
Sub HandleFolder(fldr As Folder)
Dim f As File
Dim subFldr As Folder
' loop thru files in this folder
For Each f In fldr.Files
Debug.Print f.Path
Next
' loop thru subfolders
For Each subFldr In fldr.SubFolders
HandleFolder subFldr
Next
End Sub
IDK it it helps but this is a pretty solid frame
path = "yourpath" & "\"
Filename = Dir(path & "*.fileextension")
Do While Len(Filename) > 0
'some code
Filename = Dir
Loop

VBA macro that copy files from multiple subfolders

I have a VBA for copying images from one folder to another based on image names. You can check macro in work in attached. Code is:
Option Explicit
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 2
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
sFileType = ".jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Images have been moved. Thank you!" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("B" & CStr(iRow)).Value = "Does Not Exists"
Range("B" & CStr(iRow)).Font.Bold = True
Else
Range("B" & CStr(iRow)).Value = "On Hand"
Range("B" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
However, I need 2 more things to add to this code:
When I enter the name of the file to be copied, I also want to copy
files that have the same name PLUS extension _01/_02/.../_07 if
those exist.
I want macro to look not only inside specified folder but also in
subfolders inside the folder and subfolders inside the subfolder
etc.
Can anyone help?
Thanks!
What you need is some Recursive Subs to find all the similar filenames based on the Range value.
Here I will approach this goal with below code with a couple of steps:
For each Range value (stored as a Key in Dictionary), find all the file names (exact and similar as Item in Dictionary). Joining each finding with "|" (an illegal file name character).
Process the Dictionary items after all files and sub folders from Source Path
For each Item in the dictionary of a key, see if existing file in destination folder. Append " (i)" to destination file name if already exists.
Copy the destination file to destination folder.
While copying, it returns the
Stop looping when first Empty cell is encountered
NOTE: Code not been tested, only compiled fine
Option Explicit
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
Private Const sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
Private Const sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
Private Const sFileType = "jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
Private Const DIV = "|" ' A character that's not legal file name
Private objFSO As Object, objDict As Object
Sub CopyFilesAlike()
Dim lRow As Long, sName As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(sSourcePath) Then
MsgBox "Source folder not found!" & vbCrLf & sSourcePath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
If Not objFSO.FolderExists(sDestinationPath) Then
MsgBox "Destination folder not found!" & vbCrLf & sDestinationPath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
' Proceed when both Source and Destination folders found
Set objDict = CreateObject("Scripting.Dictionary")
lRow = 2
Do Until IsEmpty(Cells(lRow, "A")) ' Stop on first empty cell in Column A from lRow
' Get Main file name to look up
sName = Cells(lRow, "A").Value
' Look for files (exact and alikes from sub folders) to add to dictionary
LookForFilesAlike sName, objFSO.GetFolder(sSourcePath)
' Copy files
If objDict.Count = 0 Then
Cells(lRow, "B").Value = "No files found."
Else
Cells(lRow, "B").Value = objDict.Count & " filenames(s) found." & vbLf & CopyFiles
End If
' Clear the Dictionary for next Name
objDict.RemoveAll
' Increment row counter
lRow = lRow + 1
Loop
Set objDict = Nothing
I_AM_DONE:
Set objFSO = Nothing
End Sub
Private Sub LookForFilesAlike(ByVal sName As String, ByVal objFDR As Object)
Dim oFile As Object, oFDR As Object
' Add files of current folder to dictionary if name matches
For Each oFile In objFDR.Files
If InStr(1, oFile.Name, sName, vbTextCompare) = 1 Then ' Names beginning with sName
' Check the extension to match
If LCase(objFSO.GetExtensionName(oFile)) = LCase(sFileType) Then
If objDict.Exists(oFile.Name) Then
' Append Path to existing entry
objDict.Item(oFile.Name) = objDict.Item(oFile.Name) & DIV & oFile.Path
Else
' Add Key and current path
objDict.Add oFile.Name, oFile.Path
End If
End If
End If
Next
' Recurse into each sub folder
For Each oFDR In objFDR.SubFolders
LookForFilesAlike sName, oFDR
Next
End Sub
Private Function CopyFiles() As String
Dim i As Long, oKeys As Variant, oItem As Variant, iRepeat As Integer, sName As String, sOut As String
sOut = ""
' Process the items for each key in Dictionary
Set oKeys = objDict.Keys ' <- Add "Set " before oKeys
For i = 0 To objDict.Count
For Each oItem In Split(objDict.Item(oKeys(i)), DIV)
' Determine the filename in destination path
If objFSO.FileExists(sDestinationPath & objFSO.GetFileName(oItem)) Then
' Same file name alreay found, try append " (i)"
iRepeat = 0
Do
iRepeat = iRepeat + 1
sName = objFSO.GetBaseName(oItem) & " (" & iRepeat & ")" & objFSO.GetExtensionName(oItem)
Loop While objFSO.FileExists(sDestinationPath & sName)
sName = sDestinationPath & sName
Else
' First file to be copied to destination folder
sName = sDestinationPath
End If
' Copy the source file to destination file
If Len(sOut) = 0 Then
sOut = oItem & DIV & sName
Else
sOut = sOut & vbLf & oItem & DIV & sName
End If
objFSO.CopyFile oItem, sName
Next
Next
CopyFiles = sOut
End Function

PDF file seach and sending it through outlook

the below code search for the file in the mentioned folder and send the searched file through outlook. But I need to add few more conditions to it.
It should also mention the count of files found in the folder with the same name > duplicate files< and put the count in excel sheet next to the file name.
The below code only search in a respective folder and not in sub-folders. It should search in sub-folders as well inside the folder for the files.
Sub CheckandSend()
Dim obMail As Outlook.MailItem
Dim irow As Integer
Dim dpath As String
Dim pfile As String
`dpath = "xxxx"
`'' loop through all files and send mail
irow = 1
Do While Cells(irow, 1) <> Empty
'' get file name in column A
pfile = Dir(dpath & "\*" & Cells(irow, 1) & "*")
'' check file exist and pdf file
If pfile <> "" And Right(pfile, 3) = "pdf"
Then
Set obMail = Outlook.CreateItem(olMailItem)
With obMail
.To = "xxx#domain.com"
.Subject = "123"
.BodyFormat = olFormatPlain
.Body = "123"
.Attachments.Add (dpath & "\" & pfile)
.Send
End With
End If
irow = irow + 1
Loop
End sub
You could simplify your code to this, which will search the directory (and sub-directories) for all PDF files using Windows scripting and then send each file found.
This handles your second issue, but I don't understand your first issue as:
a) How can you have identically named files in the same folder?
b) You haven't showed what you have tried yourself so far.
Sub SO()
Const masterFolder As String = "C:\Users\Macro Man\Files"
Dim files, file
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & masterFolder & "\*.pdf"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
With Outlook.CreateItem(0)
.To = "xxx#domain.com"
.Subject = "123"
.BodyFormat = olFormatPlain
.Body = "123"
.Attachments.Add CStr(file)
.Send
End With
Next
End Sub