VBA宏自动填充邮件表格遇Run-time error '9'下标越界问题求助

核心错误原因 #

• 数组下标不匹配：你通过NumberOfErrors计算错误数量并重新定义数组ErrorArray，但后续判断错误类型时用了ElseIf——这导致当H4单元格包含多个错误关键词时，只会匹配第一个符合条件的，不会填充多个数组元素。比如H4同时有"Max Interrogation Cycle"和"AMI"，NumberOfErrors会计算为2，但ElseIf只会填充ErrorArray(1,1)，ErrorArray(1,2)未被赋值，后续拼接strBody时访问该下标就会触发"下标越界"错误。
• 错误数量计算逻辑缺陷：用Len(Range("H4").Value) - Len(Replace(Range("H4").Value, "//", ""))计算错误数量的逻辑不准确，如果H4包含多个错误关键词却没有"//"，NumberOfErrors会被错误设为0或1，导致数组大小和实际需要填充的元素数量不匹配。

修正方案 #

1. 把判断错误类型的ElseIf替换为独立的If语句，确保多个错误关键词都能被匹配并填充数组
2. 调整错误数量计算逻辑，先统计实际匹配到的错误数量，再定义数组大小
3. 改用循环拼接表格行，避免为每个错误数量写冗余的If Else分支

修正后的代码 #

Sub DeltaQueryEmailToo()
    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Dim strBody As String, ErrorArray() As String
    Dim NumberOfErrors As Integer, i As Integer

    Set OutlookApp = New Outlook.Application
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)

    ' 初始化错误计数
    NumberOfErrors = 0

    ' 先统计实际匹配到的错误数量
    If Range("N2").Value = "Delta" Then
        If InStr(1, Range("H4").Value, "Max Interrogation Cycle", vbTextCompare) > 0 Then
            NumberOfErrors = NumberOfErrors + 1
        End If
        If InStr(1, Range("H4").Value, "AMI", vbTextCompare) > 0 Then
            NumberOfErrors = NumberOfErrors + 1
        End If
        If InStr(1, Range("H4").Value, "Action", vbTextCompare) > 0 Then
            NumberOfErrors = NumberOfErrors + 1
        End If
    End If

    ' 处理H4不为空但未匹配到关键词的情况
    If NumberOfErrors = 0 Then
        If Len(Range("H4").Value) > 0 Then
            NumberOfErrors = 1
        End If
    End If

    ' 根据实际错误数量定义数组
    ReDim ErrorArray(1 To 2, 1 To NumberOfErrors)
    i = 1

    ' 填充错误数组
    If Range("N2").Value = "Delta" Then
        If InStr(1, Range("H4").Value, "Max Interrogation Cycle", vbTextCompare) > 0 Then
            ErrorArray(1, i) = "Max Interrogatn Cycle"
            ErrorArray(2, i) = "365"
            i = i + 1
        End If
        If InStr(1, Range("H4").Value, "AMI", vbTextCompare) > 0 Then
            ErrorArray(1, i) = "Rim AMI"
            ErrorArray(2, i) = "Yes"
            i = i + 1
        End If
        If InStr(1, Range("H4").Value, "Action", vbTextCompare) > 0 Then
            ErrorArray(1, i) = "Action"
            ErrorArray(2, i) = "Yes"
            i = i + 1
        End If
    End If

    ' 生成邮件主体框架
    strBody = "<html><style>" & _
        "table {width: 60%;}" & _
        "th, td {text-align: center; padding: 5px; border-collapse: collapse; border: 1px solid}" & _
        "th {background-color: #02A4E1; color: black}" & _
        "</style><body>" & _
        "<p>Hi Team,<br><br>Please do the needful (below table) at earliest & advise the same : <br><br></p>" & _
        "<table><tr>" & _
        "<th>ICP</th><th>Error Field in payload</th><th>Expected Value</th><th>Re-trigger required (Y/N)</th><th>Notes</th>" & _
        "</tr>"

    ' 循环添加表格行
    If NumberOfErrors = 0 Then
        strBody = strBody & "<tr><td>-</td><td>-</td><td>-</td><td>-</td><td>-</td></tr>"
    Else
        For i = 1 To NumberOfErrors
            strBody = strBody & "<tr>" & _
                "<td>" & Range("D4").Value & "</td><td>" & ErrorArray(1, i) & "</td><td>" & ErrorArray(2, i) & "</td><td>-</td><td>-</td>" & _
                "</tr>"
        Next i
    End If

    ' 收尾邮件内容
    strBody = strBody & "</table>" & _
        "<p>Kind regards,<br></p></body></html>"

    On Error Resume Next
    With OutlookMail
        .To = "Email@Email.com"
        .CC = "Email@Email.com"
        .Subject = "ICP " & Range("D4").Value & " - Query"
        .Display
        .HTMLBody = strBody & .HTMLBody
    End With
    On Error GoTo 0

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

额外优化说明 #

• 用vbTextCompare替代1，代码可读性更强
• 循环拼接表格行的方式，无需为每个错误数量写单独分支，后续新增错误类型时扩展性更好
• 先统计错误数量再定义数组，确保数组大小和实际填充的元素数完全匹配

内容的提问来源于stack exchange，提问作者Aaron