Assigning macro to each button to zip files dependent on button name

Hi -

Welcome to the board.

change the zip macro to something like this;

Sub Zip()

to

Sub Zip(empName as string)

then change the

FileNameZip = SavePath & "Anthony Tran " & strDate & ".zip"

to

FileNameZip = SavePath & empName & " " & strDate & ".zip"

finally change the onaction

.OnAction = "Zip" ' Assigns macro "Zip" to each button

to

.OnAction = "'Zip""" & Range("b" & I) & """'" ' Assigns macro "Zip" to each button

event

Thanks a lot for your reply event. I actually managed to get the code to do exactly what I need it to do. The problem I have now is that the macro keeps looping and creating the same zip file over and over and over until I force quit Excel. Here's the code:

Sub WhichButton()

Dim strDate As String, SavePath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim vArr, FileNameZip
Dim FName() As Variant

         ' Assign the calling object to a variable.
ButtonName = Application.Caller
RowCount = Cells(Cells.Rows.Count, "c").End(xlUp).Row       ' Value being searched is in column c

For I = 2 To RowCount + 1
    Select Case ButtonName          ' Display the name of the button that was clicked.
        Case Range("B" & I)

            SavePath = "C:\Users\MDuff3\Desktop\" 'save zip location
            strDate = Format(Now, " dd-mmm-yy h-mm-ss")
            FileNameZip = SavePath & ButtonName & strDate & ".zip"

            FName = Array("Y:\Administration\Personnel\Certifications And Identification\CSTP\" & ButtonName & "_CSTP.pdf\")

                If IsArray(FName) = False Then
                        'do nothing
                Else
                        'Create empty Zip File
                    NewZip (FileNameZip)
                    Set oApp = CreateObject("Shell.Application")
                    I = 0
                    For iCtr = LBound(FName) To UBound(FName)
                    vArr = Split97(FName(iCtr), "\") 'splits raw directory into array at each "/"
                    sFName = vArr(UBound(vArr)) 'picks final part of array which is the filename
                If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
                Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr
        MsgBox "You find the zipfile here: " & FileNameZip
    End If

         End Select
Next
      End Sub

Sub NewZip(sPath)
'Create empty Zip File
    If Len(Dir(sPath)) > 0 Then Kill sPath 'If the zip file name already exists
    
    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

Any idea how I can change this code to make it create the zipped file only once?

Hi -

Thanks a lot for your reply event. I actually managed to get the code to do exactly what I need it to do.

Good for you.

event

Any idea how I can get my macro to stop repetitively creating the zipped files?

Also posted: www.ozgrid.com/forum/showthread.php?t=185724