excel 2013 keeps crashing : my excel vb macro keeps crashing excel spreadsheet.

i know my macros must be full of bad techniques and coding, but please help where you can.  it might be because i am asking excel to send multiple sms texts/emails or perhaps my keyval function.  please help

- - - - - - 

    Option Explicit
    
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim d As Integer
    Dim e As Integer
    
    Dim em As String
    Dim st As String
    Dim str As String
    Dim em2 As String
    
    Dim mon As Worksheet
    
    Sub SingleButtonEvent()
    
    Set mon = Sheets("MON")
    
    st = ""
    ActiveSheet.Unprotect
    If ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row < 30 Then
    
    a = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
    If mon.Cells(a, "BB") = "" Then
    'MsgBox "No Number in Column BB. Message Will Not Send", vbCritical
    Exit Sub
    Else
    em = mon.Cells(a, "BB").Value
    
    With Cells(a, "AV").Font
    
        .Color = RGB(166, 166, 166)
        .Size = 12
    
    End With
    
    Call SendSMS
    
    
    
    End If
    Else
    
    For b = 1 To 29
    If Cells(b, "B") <> 0 Then
    a = b
    If mon.Cells(a, "BB") = "" Then
    
    Else
    em = mon.Cells(a, "BB").Value
    
    Call SendSMS
    
    End If
    End If
    
    Next
    
    End If
    
    ActiveSheet.Protect
    
    End Sub
    Sub SendSMS()
        
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    
    iConf.Fields.Update
    
    
    iMsg.To = em
    'Change Bellow email to your email
    iMsg.From = "test@gmail.com"
    iMsg.Subject = ""
    c = Cells(a, "A").End(xlToRight).Column
    
    st = ""
    em2 = ""
    
    If c > 2 Then
    'st = Format(Date, "DDDD") & "<br/>"
    For d = 3 To c
    
    If Cells(a, d) <> "" And CInt(Cells(30, d).Value) <= 7 Then
    st = st & Cells(30, d).Value & ". " & Application.WorksheetFunction.Clean(Cells(a, d).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 1).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 2).Value) & "<br/>"
    d = d + 2
    
    ElseIf Cells(a, d) <> "" And CInt(Cells(30, d).Value) > 7 Then
    If em2 = "" Then
    em2 = Cells(30, d).Value & ". " & Application.WorksheetFunction.Clean(Cells(a, d).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 1).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 2).Value) & "<br/>"
    d = d + 2
    Else
    em2 = em2 & Cells(30, d).Value & ". " & Application.WorksheetFunction.Clean(Cells(a, d).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 1).Value) & " | " & Application.WorksheetFunction.Clean(Cells(a, d + 2).Value) & "<br/>"
    d = d + 2
    End If
    Else
    Exit Sub
    End If
    Next
    End If
    'If ActiveSheet.Name = "MON" Then
    'str = Cells(a, "B").Value
    'Else
    'str = Cells(a, "B").Value
    'End If
    
    If em2 = "" Then
    iMsg.HTMLBody = st & "Visa triet " & Cells(a, "AY").Value & "<br/>Total " & Cells(a, "B").Value & "<br/>"
    Set iMsg.Configuration = iConf
    iMsg.Send
    
    Else
    iMsg.HTMLBody = st
    Set iMsg.Configuration = iConf
    iMsg.Send
    iMsg.HTMLBody = em2 & "Visa " & Cells(a, "AY").Value & "<br/>Total " & Cells(a, "B").Value & "<br/>"
    Set iMsg.Configuration = iConf
    iMsg.Send
    End If
    
    Set iMsg = Nothing
    End Sub
    
    Function KeyVal(ParamArray ran() As Variant)
    Application.Volatile True
    Dim str As String
    a = 0
    
    Do While a < UBound(ran) + 1
    
    
    If ran(a) = 0 Or ran(a) = "" Then
    a = a + 1
    Else
    b = Sheets("Key").Cells(Rows.Count, "A").End(xlUp).Row
    str = ran(a)
    
    If InStr(str, "/") > 0 Then
    Do While InStr(str, "/") > 0
    d = Application.WorksheetFunction.Search("/", str)
    st = Mid(str, 1, d - 1)
    str = Application.WorksheetFunction.Clean(Trim(Mid(str, d + 1, Len(str))))
    
    For c = 1 To b
    
    If LCase(st) = LCase(Sheets("Key").Cells(c, "A").Value) Then
    
    KeyVal = KeyVal + Sheets("Key").Cells(c, "B").Value
    
    End If
    
    Next
    If InStr(str, "/") <= 0 Then
    
    For c = 1 To b
    
    If str = Sheets("Key").Cells(c, "A").Value Then
    
    KeyVal = KeyVal + Sheets("Key").Cells(c, "B").Value
    
    End If
    
    Next
    
    End If
    Loop
    
    Else
    
    For c = 1 To b
    
    If ran(a) = Sheets("Key").Cells(c, "A").Value Then
    
    KeyVal = KeyVal + Sheets("Key").Cells(c, "B").Value
    
    End If
    
    Next
    
    End If
    a = a + 1
    End If
    Loop
    
    End Function



