VBA to Zip all Folders into files separately with same name

fleyd

New Member
Joined
Jan 21, 2020
Messages
22
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. Web
Hello everyone,

I have searched the forum but cant seem to find exactly what I'm looking.

I would like a VBA code that according the folder where excel file (VBA) is:
- Will zip all folders (and it´s content) into zip files with the same names
- Don´t want or need to choose names of the files or destination folders
- Destination folder must be the exact same folder where the excel file with the VBA code is
- The folder will be / is a windows network folder

Imagine my excel file is at folder name Fruit, and inside that folder i have sub Folders:
apple
grapes
almonds


What i want, is to run the macro and on that same folder, Fruit, have apple.zip + grapes.zip + almonds.zip
And if i run the macro again, the code should overwritten the zip files according to the new files or folders inside folder Fruit

Appreciate your help, i have tried other codes here from the forum but for some reason i couldn't get them to work, mainly because they do different things from what i´m looking.
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Hi fleyd. It seems like this adaptation of Mr. de Bruin's code will work for U. HTH. Dave
module code...
Code:
Public Function ZipSubFolders(ZipThatFolder As String)
'zip sub folders in ZipThatFolder
'ie. Call ZipSubFolders(GetThatFolder)
Dim FsoObj As Object, SubF As Object, xFS As Object
Dim Temp2 As Object, Foldername As String
Set FsoObj = CreateObject("Scripting.FileSystemObject")
Set xFS = FsoObj.GetFolder(ZipThatFolder)
For Each SubF In xFS.SubFolders
'can't zip empty folders
If Dir(SubF.Path & "\" & "*.*") <> "" Then
On Error Resume Next
'remove previous zip file
Set Temp2 = FsoObj.GetFile(SubF.Path & ".zip")
If Temp2 <> "" Then
FsoObj.deletefile (SubF.Path & ".zip"), False
End If
On Error GoTo 0
'zip folder
Call Zipp(SubF.Path & ".zip", SubF.Path)
Else 'remove these 2 lines as needed
MsgBox "No Files to zip in folder: " & SubF.Path
End If
Next SubF
Set Temp2 = Nothing
Set xFS = Nothing
Set FsoObj = Nothing
End Function

Public Function GetThatFolder() As String
Dim FlDr As FileDialog
Dim sItem As String
Set FlDr = Application.FileDialog(msoFileDialogFolderPicker)
With FlDr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetThatFolder = sItem
Set FlDr = Nothing
End Function

'Many thanks to Ron de Bruin for his great code
Public Function Zipp(ZipName, FileToZip)
'Zips A Folder/File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim oApp As Object, T As Double
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
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
T = Timer
Do Until Timer - T > 1
  DoEvents
Loop
Loop
On Error GoTo 0
Set oApp = Nothing
End Function
To operate..
Code:
Call ZipSubFolders(GetThatFolder)
 
Upvote 0
Solution
Hi fleyd. It seems like this adaptation of Mr. de Bruin's code will work for U. HTH. Dave
module code...
Code:
Public Function ZipSubFolders(ZipThatFolder As String)
'zip sub folders in ZipThatFolder
'ie. Call ZipSubFolders(GetThatFolder)
Dim FsoObj As Object, SubF As Object, xFS As Object
Dim Temp2 As Object, Foldername As String
Set FsoObj = CreateObject("Scripting.FileSystemObject")
Set xFS = FsoObj.GetFolder(ZipThatFolder)
For Each SubF In xFS.SubFolders
'can't zip empty folders
If Dir(SubF.Path & "\" & "*.*") <> "" Then
On Error Resume Next
'remove previous zip file
Set Temp2 = FsoObj.GetFile(SubF.Path & ".zip")
If Temp2 <> "" Then
FsoObj.deletefile (SubF.Path & ".zip"), False
End If
On Error GoTo 0
'zip folder
Call Zipp(SubF.Path & ".zip", SubF.Path)
Else 'remove these 2 lines as needed
MsgBox "No Files to zip in folder: " & SubF.Path
End If
Next SubF
Set Temp2 = Nothing
Set xFS = Nothing
Set FsoObj = Nothing
End Function

Public Function GetThatFolder() As String
Dim FlDr As FileDialog
Dim sItem As String
Set FlDr = Application.FileDialog(msoFileDialogFolderPicker)
With FlDr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetThatFolder = sItem
Set FlDr = Nothing
End Function

'Many thanks to Ron de Bruin for his great code
Public Function Zipp(ZipName, FileToZip)
'Zips A Folder/File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim oApp As Object, T As Double
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
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
T = Timer
Do Until Timer - T > 1
  DoEvents
Loop
Loop
On Error GoTo 0
Set oApp = Nothing
End Function
To operate..
Code:
Call ZipSubFolders(GetThatFolder)
Hi,

Thanks for the help!

I´ve pasted the code into Excel and i can see i now have 2 functions "Zipp" and "ZipSubFolders" but i can´t get them to work...

Am i supposed to do something like
VBA Code:
=Zipp(path)
? because i´ve tried with a network folder like \\folder\1\fruit and it´s not working...

Sorry my VBA skills are not great..
 
Upvote 0
Hi again fleyd. If U want to select the folder manually run the ZipSubFolders sub with GetThatFolder. For example, place an active x command button on your sheet, select design mode, right click on the command button, select view code and paste this as code for the command button...
Code:
Call ZipSubFolders(GetThatFolder)
Exit design mode and then click the command button.
To directly enter the folder path, instead of the previous code, insert the full folder path..
Code:
Call ZipSubFolders("\\folder\1\fruit")
HTH. Dave
 
Upvote 0
Hi again,

I´ve managed to get it to work following your advice. Thanks

Any way i can reference the folder path in a cell, for example Tab "fruit" Cell A1 . And in A1 there will be \\folder\1\fruit
Something like Call ZipSubFolders("fruit!a1") or Call ZipSubFolders("fruit!a1") ? Is this possible?
 
Upvote 0
Hi again everyone,

@NdNoviceHlp , if possible would to request another thing, any chance for the created zips to have maximum size of 28 MB ?
If any of the zips exceed 28MB, a new volume should be created and add to the name something like this :
"name of the folder - Part 1"
"name of the folder - Part 2"
and so on...

Sorry to ask for something more, but this will be very helpfull.

Thanks in advance.
 
Upvote 0
Hi again fleyd. It would probably be pretty easy to determine by code how big the file size is (ie. is it larger than 28MB) but as for splitting it into smaller pieces I have no ideas how to make this possible. I'll google around and reply if I happen to find anything similar. Sorry I can't be of any other assistance. Good luck. Dave
 
Upvote 0

Forum statistics

Threads
1,223,900
Messages
6,175,276
Members
452,629
Latest member
SahilPolekar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top