Excel 2013不断崩溃

Question

我的Excel VBA宏不断崩溃Excel电子表格。这可能是因为我要求Excel发送多个短信文本/电子邮件或者我的keyval函数。

---

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 

Answer 1

使用CINT（RAN）可变跑。

对keyval使用CDouble（keyval）。