In Column B I have a series of folder names (e.g. Oranges, Apples, Lemons).

I have 600 filenames in Column C (e.g. small.pdf, medium.pdf, large.docx).

The path of those files is in Column D (e.g. \\bidntfs1.fruit.bz\main\dept\team\ ).

The files are labelled as "Asset" or "Source" in Column E

If the label in Column E = "Source", I want create a zip folder of all the Source files for Oranges, a zip folder of all the Source files for Apples etc.

If the label in Column E = "Asset", I want the files to remain outside of the zipped folder in one master folder containing ALL of the Asset files.

I'm using this VBA code below but it's zipping everything. It was written by an ex colleague and I have a basic/intermediate understanding of VBA.

Can anyone help me out please?


' Add references via Tools --> References:
' 1) Microsoft Scripting Runtime
' 2) Microsoft Shell Controls And Automation
' 3) Microsoft Office xx.x Object Library

' Run the ZipSubFolders procedure:

Public Sub ZipSubFolders()
Const msoFileDialogFolderPicker = 4
Dim objFolderPicker As Office.FileDialog
Dim intSubFolders As Integer
Dim strFolderPath As String
Dim objShell As New Shell32.Shell

On Error GoTo ErrHandler
Set objFolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
objFolderPicker.InitialFileName = Environ("UserProfile") & "\Documents"
objFolderPicker.ButtonName = "Zip Subfolders"
objFolderPicker.Title = "Pick a folder"

If objFolderPicker.Show() Then
strFolderPath = objFolderPicker.SelectedItems(1)
intSubFolders = ZipEachSubFolder(strFolderPath)
' MsgBox intSubFolders & " subfolder(s) were zipped.", vbInformation
objShell.ShellExecute "explorer.exe", strFolderPath
End If

ExitProc:
Set objFolderPicker = Nothing
Set objShell = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub

Private Function ZipEachSubFolder(FolderPath As String) As Integer
Dim objSubFolder As Scripting.Folder
Dim objFileSys As New Scripting.FileSystemObject
Dim objFolder As Scripting.Folder

Set objFolder = objFileSys.GetFolder(FolderPath)
For Each objSubFolder In objFolder.SubFolders
If ZipFolder(objSubFolder.Path) Then
ZipEachSubFolder = ZipEachSubFolder + 1
End If
Next objSubFolder

ExitProc:
Set objSubFolder = Nothing
Set objFileSys = Nothing
Set objFolder = Nothing
End Function

Private Function ZipFolder(FolderPath As String) As Boolean
Dim strParentFolderPath As String
Dim strZipFilePath As String
Dim strFolderName As String
Dim objFileSys As New Scripting.FileSystemObject
Dim objStream As Scripting.TextStream
Dim objFolder As Scripting.Folder
Dim objShell As New Shell32.Shell

On Error GoTo ErrHandler
Set objFolder = objFileSys.GetFolder(FolderPath)
strParentFolderPath = objFolder.ParentFolder.Path & ""
strFolderName = objFolder.Name

strZipFilePath = strParentFolderPath & strFolderName & ".zip"
Set objStream = objFileSys.CreateTextFile(strZipFilePath, True)
objStream.Close

objShell.Namespace(strZipFilePath).CopyHere objShell.Namespace(FolderPath).Items
ZipFolder = True

ExitProc:
On Error Resume Next
objStream.Close
Set objFileSys = Nothing
Set objStream = Nothing
Set objFolder = Nothing
Set objShell = Nothing
Exit Function

ErrHandler:
ZipFolder = False
Resume ExitProc
End Function