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
Related
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
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
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.
I have mutiple folders (appox. 400 and could increase up in some cases) and each of these folders contains some files. I wanted to zip all these folders with their contents and create 400 zip files. I wanted to automate this with VBA. I tried with the following code. The standard one which uses shell application.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).Items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).Items.Count = _
oApp.Namespace(FolderName).Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
I can call the above code in loop to create mutiple zip folders. However, I was wondering if this is really an effcient process! Is there any alternative for this procedure? Sometimes my count of folders to be zipped may go beyound 1000. So I would really appreciate your suggestions and ideas on this.
Thank you in advance
Well, if you don't need everything separated into 400 different folders, you can combine them all into one zipped folder.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = _
oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
https://www.rondebruin.nl/win/s7/win001.htm
I am writing some code that prompts the user to add a folder name, then copies all the files on the CD drive (D:) to C:\Example\ & FolderName if it doesn't already exist.
The code works until I try to copy files to a folder that already exists then I get a Run-time error 70: Permission Denied. Any help would be greatly appreciated.
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
End Sub
The problem is not that the folder exists. The problem is that you are trying to copy files and overwrite them
Overwriting is usually not a problem but fails if the files in the destination folder have Read Only Attributes. You can read more about it in this MSDN Article
What happened was when you first copied the files from the CD Drive, the file which where copied retained the Read Only Property. You can check that by Right Clicking on the File and checking their properties.
To overcome this problem, you need to reset the file attributes or delete the files in that folder.
To delete, you can simply use
On Error Resume Next
Kill "C:\MyFolder\*.*"
On Error GoTo 0
To change the attributes, you have to loop through the file and check if their property is read only. You can do that by
If fso.GetFile(Dest_File).Attributes And 1 Then
and to reset it, you have to use
fso.GetFile(Dest_File).Attributes = fso.GetFile(Dest_File).Attributes - 1
Once you do that you will be able to copy the files across.
As Siddharth mentioned, the error occurs because the code is trying to overwrite existing files. So, if you don't want to overwrite the files, you can simply add a If Error Resume Next. The solution code I am using is below:
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
On Error GoTo 0
End Sub