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

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

Related

How to unzip files with same name in VBA?

I have a bunch of zip folders in a directory that I am trying to unzip with VBA. I am using the following code:
Sub UnzipAll()
Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
Dim folder As Variant: folder = Dir(ThisWorkbook.Path & "\Attachments\")
While (folder <> "")
If InStr(folder, ".zip") > 0 Then
oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items
End If
folder = Dir
Wend
End Sub
This works just fine, but runs into a problem: when two zip folders contain a file with the same name, a prompt pops up asking if I want to replace or keep both.
How can I make it so that it extracts both files, keeping both? Maybe putting a number after one to differentiate?
Thanks!
Disclaimer: This is a total shot in the dark, but this might work. I'm just not familiar with this .Namespace or .CopyHere syntax, but I think this would work (appending a number to the end of files that already exist at the location).
Sub UnzipAll()
Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
Dim folder As Variant: folder = Dir(ThisWorkbook.Path & "\Attachments\")
Dim i As Long
i = 1
While (folder <> "")
If InStr(folder, ".zip") > 0 Then
If Dir(ThisWorkbook.Path & "\Attachments\" & oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items) = "" Then
oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items
Else
oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items & i
i = i + 1
End If
End If
folder = Dir
Wend
End Sub

How can I delete a file based on cell value?

I'm having trouble deleting a file based on cell value.
I get an error message on the line with the Kill command below:
Kill path & r.Offset(1, -4) & "\" & r.Offset(1, -3)
Any ideas?
Sub INACTIVE_files()
Const path = "C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\"
Dim r As Range
Dim x As Integer
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.value) = "INACTIVE" Then
Kill path & r.Offset(1, -4) & "\" & r.Offset(1, -3)
End If
Set r = r.Offset(1, 0)
Loop
End Sub
The code starts from cell E1 and looks for INACTIVE files in the same column, until there's no more files to look for.
Then, it checks the folder name (Column A), combines it with the Cube (Column B)
and puts both of them in a path:
path = "C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\"
so for example:
for cell E2 which is INACTIVE, the path should be:
C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\WPO 17 02 04 3MMT All Periods\BG023104.txt
It then deletes the INACTIVE files (Cubes) from the appropriate folder.
Wrap your path in double quotes to avoid issues with spaces in filenames and folders.
Even better is to put the path in a string variable so you can debug it easily
Outside your loop:
Dim strPath As String
Inside your if block:
strPath = """" & path & r.Offset(1,-4) & "\" & r.Offset(1,-3) & """"
Debug.Print strPath ' Ctrl-G to view results
Kill strPath
EDIT - add a check for file before deleting
Under Tools | References
Add a reference to Windows Script Hosting
Then at top of sub code add
Dim fso as New FileSystemObject
Replace your Kill command with a check for existence
If fso.FileExists(strPath) Then
Kill strPath
Else
Msgbox "File Doesn't Exist: " & strPath
End If
UPDATED FOR CONTINUE TO NEXT FILE
Change loop to be:
Do Until r = ""
If UCase(r.value) = "INACTIVE" AND fso.FileExists(strPath) Then
Kill strPath
End If
Set r = r.Offset(1, 0)
Loop
It works!
I've commented out some parts of the code that were used for checking if a file exists.
Sub delete_INACTIVE_files()
Const path = "C:\Users\Dn\AppData\Local\Temp\vbakillfunction\"
Dim r As Range
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.Value) = "INACTIVE" Then
If Dir(path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt") <> "" Then 'Does the file exist?
'MsgBox "file" & path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt" & " exists"
Kill path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt"
'Else
'MsgBox "file" & path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt" & " not here"
End If
End If
Set r = r.Offset(1, 0)
Loop
End Sub

Automated sorting of files into folders using excel VBA

I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub

Unable to search/loop through subfolders

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.

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.