Macro won't stop creating zipped files

[mduff3]

I have a code that creates a zipped file that saves to the desktop. The macro works fine except it repeats itself and doesn't stop. How can I change the following code so that it only creates one zipped file?

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

 

[dermie_72]

is it because of the rowcount?, or the ictr? If you step through the macro it should tell you which on is causing it to continuously loop.