Zipping Files

[luckee]

Hi, want to make some changes to the below in red so it picks up the information from the active sheet rather than changing in the code.

Zip file(s) with the default Windows zip program (VBA)

Sub Zip_All_Files_in_Folder()
Dim FileNameZip, FolderName
Dim strDate As String, DefPath As String
Dim oApp As Object

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FolderName = "C:\Users\Ron\test\" '<< Change 1. How to change this so it can reference the path on Sheet1 cell A1?

strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip" 2. How to change this so it can pick up the file name from Sheet1 cell A2?

'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")
'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 Sub

Thank you.

 

[Domenic]

Try...

FolderName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value

and

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value

Change the workbook and worksheet references as desired.

Hope this helps!

 

[luckee]

Try...

FolderName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value

and

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value

Change the workbook and worksheet references as desired.

Hope this helps!

Hi, thank you! The FolderName worked but I'm getting a Run-time error '76': Path not found message for the file name

 

[Domenic]

What value does cell A2 contain?

 

[luckee]

What value does cell A2 contain?

XXXX 06.30.2023

 

[Domenic]

In that case, try the following instead...

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value & ".zip"

 

[luckee]

In that case, try the following instead...

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value & ".zip"

Hi, still getting the same error...the below in red highlights in yellow. Thank you.

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

 

[luckee]

Hi, still getting the same error...the below in red highlights in yellow. Thank you.

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

Putting the entire code...getting Run-time error '13': Type mismatch

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


Sub Zip_All_Files_in_Folder()
Dim FileNameZip, FolderName
Dim strDate As String, DefPath As String
Dim oApp As Object

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FolderName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value '<< Change

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value & ".zip"

'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")
'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 Sub

 

[Domenic]

If Len(Dir(sPath)) > 0 Then Kill sPath

I don't see how you're getting a type mismatch error for the above line of code. In any case, try running your code line-by-line by pressing F8 until you've executed this line...

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value & ".zip"

Then enter the following in the Immediate Window (Ctrl-G), and press the ENTER key...

? FileNameZip

Now, make sure that the returned string contains a valid path, and that the filename doesn't contain any illegal characters.

 

[luckee]

I don't see how you're getting a type mismatch error for the above line of code. In any case, try running your code line-by-line by pressing F8 until you've executed this line...

FileNameZip = DefPath & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value & ".zip"

Then enter the following in the Immediate Window (Ctrl-G), and press the ENTER key...

? FileNameZip

Now, make sure that the returned string contains a valid path, and that the filename doesn't contain any illegal characters.

Thank you. Valid path, no issues...I get a Run-time error '76': Path not found on this line now - Open sPath For Output As #1