VBA to Zip all Folders into files separately with same name

[fleyd]

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.

 

[NdNoviceHlp]

Hi fleyd. It seems like this adaptation of Mr. de Bruin's code will work for U. HTH. Dave
module 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..

Call ZipSubFolders(GetThatFolder)

 

[fleyd]

Hi fleyd. It seems like this adaptation of Mr. de Bruin's code will work for U. HTH. Dave
module 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..

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

=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..

 

[NdNoviceHlp]

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...

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..

Call ZipSubFolders("\\folder\1\fruit")

HTH. Dave

 

[fleyd]

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?

 

[NdNoviceHlp]

Seems like this should work...

Call ZipSubFolders(CStr(Sheets("Fruit").Range("A1")))

Dave

 

[fleyd]

Seems like this should work...

Call ZipSubFolders(CStr(Sheets("Fruit").Range("A1")))

Dave

Yes it did, worked perfectly.

Thanks a lot!

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Enjoy a safe Holiday season. Dave

 

[fleyd]

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.

 

[NdNoviceHlp]

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