Excel VBA勾选复选框发邮件报错‘Subscript out of range’求助

问题描述 #

工作表包含复选框和对应条目（Type、Item、Quantity、Unit），需求是勾选复选框后将对应条目通过邮件发送，但运行VBA代码时触发「Subscript out of range」（下标越界）错误。

错误原因分析 #

1. 数组声明与初始化错误：CommandButton2_Click中arrQuantity声明为Integer、arrUnit声明为String，并非数组，无法存储多条勾选记录；itemStored子过程中直接给未初始化的动态数组赋值，导致下标越界。
2. 复选框行关联错误：遍历复选框时未获取其所在行，用i+4硬编码行号完全不符合实际表格结构，无法正确读取对应条目。
3. 语法错误：创建Outlook对象时少了闭合括号，导致对象初始化失败。
4. 数组循环逻辑错误：sendEmail中从i=4开始循环数组，未考虑数组的实际起始下标（动态数组默认从0开始），会引发越界或数据读取遗漏。
5. 单元格列引用错误：itemStored中所有值都读取I列，未对应Type、Item等不同列，数据获取完全错误。

修正后的完整代码 #

Private Sub sendEmail(arrType As Variant, arrItem As Variant, arrQuantity As Variant, arrUnit As Variant)
    Dim i As Integer
    Dim objOutlook As Object
    ' 修复Outlook对象创建的语法错误
    Set objOutlook = CreateObject("outlook.application")
    Dim ws As Worksheet
    Dim strSubject As String
    Dim strBody As String
    Dim strTable As String
    Dim strHTML As String
    Set ws = ThisWorkbook.Worksheets("Data")
    
    strSubject = "Testing"
    strBody = "<html>"
    strBody = strBody & "Please see the order details below for your reference:<br><br>"
    strTable = "<br><table border = 2><tbody>"
    strTable = strTable & "<tr>"
    strTable = strTable & "<th align = center> Type</th>"
    strTable = strTable & "<th align = center> Item</th>"
    strTable = strTable & "<th align = center> Quantity</th>"
    strTable = strTable & "<th align = center> Unit</th>"
    strTable = strTable & "</tr>" ' 修复表格行闭合标签错误
    
    ' 从数组起始下标循环到结束下标，避免越界
    For i = LBound(arrType) To UBound(arrType)
        strTable = strTable & "<tr><td>" & arrType(i) & "</td>"
        strTable = strTable & "<td>" & arrItem(i) & "</td>"
        strTable = strTable & "<td>" & arrQuantity(i) & "</td>"
        strTable = strTable & "<td>" & arrUnit(i) & "</td></tr>"
    Next
    strTable = strTable & "</tbody></table><br>"
    strHTML = strBody & strTable & "</html>"
    
    If MsgBox("Are you sure you want to submit? ", vbYesNo, "Submit Confirmation") = vbYes Then
        Dim objEmail As Object
        Set objEmail = objOutlook.CreateItem(0)
        With objEmail
            .To = "" ' 填写收件人邮箱
            .Subject = strSubject
            .HTMLBody = strHTML
            .Display ' 调试时可以先Display，确认后再改为.Send
            '.Send
        End With
        MsgBox "Thanks for the order. Your order details are sent successfully.", vbOKOnly, "Operation Successful"
    Else
        Exit Sub
    End If
End Sub

Private Sub itemStored(ByRef arrType As Variant, ByRef arrItem As Variant, ByRef arrQuantity As Variant, ByRef arrUnit As Variant)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Data")
    
    Dim i As Long
    Dim cb As CheckBox
    Dim count As Long
    
    ' 先统计勾选的复选框数量
    count = 0
    For Each cb In ws.CheckBoxes
        If cb.Value = 1 Then
            count = count + 1
        End If
    Next
    
    ' 初始化动态数组大小
    If count > 0 Then
        ReDim arrType(0 To count - 1)
        ReDim arrItem(0 To count - 1)
        ReDim arrQuantity(0 To count - 1)
        ReDim arrUnit(0 To count - 1)
        
        i = 0
        For Each cb In ws.CheckBoxes
            If cb.Value = 1 Then
                Dim rowNum As Long
                rowNum = cb.TopLeftCell.Row ' 获取复选框所在行
                ' 读取对应列的值（根据实际表格调整列号，示例中Type=F列, Item=G列, Quantity=H列, Unit=I列）
                arrType(i) = ws.Cells(rowNum, "F").Value
                arrItem(i) = ws.Cells(rowNum, "G").Value
                arrQuantity(i) = ws.Cells(rowNum, "H").Value
                arrUnit(i) = ws.Cells(rowNum, "I").Value
                i = i + 1
            End If
        Next
    Else
        ' 没有勾选时初始化空数组，避免后续报错
        ReDim arrType(0 To -1)
        ReDim arrItem(0 To -1)
        ReDim arrQuantity(0 To -1)
        ReDim arrUnit(0 To -1)
        MsgBox "No items selected.", vbExclamation, "Warning"
    End If
End Sub

Private Sub cmdbtnShow_Click()
    OrderForm.Show
End Sub

Private Sub CommandButton2_Click()
    Dim arrType() As Variant
    Dim arrItem() As Variant
    Dim arrQuantity() As Variant ' 修改为数组类型
    Dim arrUnit() As Variant ' 修改为数组类型

    Call itemStored(arrType, arrItem, arrQuantity, arrUnit)
    
    ' 只有勾选了条目才发送邮件
    If UBound(arrType) >= 0 Then
        Call sendEmail(arrType, arrItem, arrQuantity, arrUnit)
    End If
End Sub

关键修改说明 #

1. 数组类型修正：将arrQuantity和arrUnit改为动态数组，通过ByRef传递，确保子过程能修改主过程中的数组。
2. 数组初始化逻辑：先统计勾选数量，再重新定义数组大小，避免下标越界；无勾选时初始化空数组，提前拦截错误。
3. 复选框行获取：用cb.TopLeftCell.Row获取复选框所在行，精准读取对应条目。
4. 语法错误修复：补上Outlook对象创建的闭合括号，修正表格行闭合标签错误。
5. 循环逻辑调整：数组循环使用LBound到UBound，适配数组实际范围，避免越界。
6. 列引用修正：根据表格实际结构读取对应列的值（需根据你的表格调整列标识，示例中用F/G/H/I列对应Type/Item/Quantity/Unit）。

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