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）进行变量运行。

使用CDouble（keyval）作为keyval。

Excel 2013不断崩溃

1 个答案: