Instantly share code, notes, and snippets.

What would you like to do?
This script loops through a column and creates zip files for each folder listed using 7-Zip
Option Explicit
Public Sub ZipFoldersInColumn()
Dim wks As Worksheet
Dim lngIdx As Long, lngErrorCode
Dim strFullPath As String, strZipName As String, strEndFound As String, _
strCommand As String, strTargetDir As String
Dim blnEndFound As Boolean
Dim wsh As WshShell
Set wsh = New WshShell
'Set references up-front
Set wks = ThisWorkbook.Worksheets("Sheet1")
blnEndFound = False
lngIdx = 7
strTargetDir = "C:\target-folder\" ' <~ adjust as necessary
strEndFound = "Arbitrary Stop String" ' <~ adjust as necessary
'Loop through column J from rows 7 to 51
While Not blnEndFound
'Assign the full filepath per the listing in the cell, then increment
strFullPath = wks.Cells(lngIdx, 10).Value
lngIdx = lngIdx + 1
'Make sure we're not at the end of the range or stop string
If strFullPath <> strEndFound And lngIdx < 51 Then
'Get the appropriate zip file name
strZipName = GetZipFileName(strFullPath)
'Form the 7-zip command line instruction
strCommand = Chr(34) & "C:\Program Files\7-Zip\7z.exe" & Chr(34) & _
" a -tzip " & _
Chr(34) & strTargetDir & strZipName & Chr(34) & _
" " & Chr(34) & strFullPath & "\" & "*" & Chr(34)
'Run the 7-zip command line instruction via thw WshShell
lngErrorCode = wsh.Run(strCommand, WindowStyle:=1, WaitOnReturn:=1)
'Check for an error from WshShell
If lngErrorCode <> 0 Then
MsgBox "Oh no! Something went wrong with Wsh!"
Exit Sub
End If
blnEndFound = True
End If
'Let the user know the script has finished
MsgBox "Zip files created!"
End Sub
Public Function GetZipFileName(FullPath As String) As String
Dim lng As Long
Dim str As String
Dim blnCharIsASlash As Boolean
'Set references up-front
blnCharIsASlash = False
lng = 0
'Walk backwards from the end of the full file path until "\"
While Not blnCharIsASlash
str = Mid(FullPath, Len(FullPath) - lng, 1)
If str = "\" Then
blnCharIsASlash = True
End If
lng = lng + 1
'Prevent an infinite loop by stopping at 1,000
If lng >= 1000 Then
MsgBox "Whoa! I got to 1000 counts before finding '\', " & _
"something is wrong!"
GetZipFileName = ""
End If
GetZipFileName = Right(FullPath, lng - 1) & ".zip"
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment