Excel VBA 窗体复选框多选工作表打印报下标越界问题

问题背景 #

现有名为Print_Form的用户窗体，包含20个复选框，窗体初始化时会自动将工作簿前20个工作表的名称赋值为对应复选框的标题，初始化代码运行无异常：

Private Sub UserForm_Initialize()
    CheckBox1.Caption = Sheets(1).Name
    CheckBox2.Caption = Sheets(2).Name
    CheckBox3.Caption = Sheets(3).Name
    CheckBox4.Caption = Sheets(4).Name
    CheckBox5.Caption = Sheets(5).Name
    CheckBox6.Caption = Sheets(6).Name
    CheckBox7.Caption = Sheets(7).Name
    CheckBox8.Caption = Sheets(8).Name
    CheckBox9.Caption = Sheets(9).Name
    CheckBox10.Caption = Sheets(10).Name
    CheckBox11.Caption = Sheets(11).Name
    CheckBox12.Caption = Sheets(12).Name
    CheckBox13.Caption = Sheets(13).Name
    CheckBox14.Caption = Sheets(14).Name
    CheckBox15.Caption = Sheets(15).Name
    CheckBox16.Caption = Sheets(16).Name
    CheckBox17.Caption = Sheets(17).Name
    CheckBox18.Caption = Sheets(18).Name
    CheckBox19.Caption = Sheets(19).Name
    CheckBox20.Caption = Sheets(20).Name
End Sub

故障现象 #

点击窗体打印按钮时触发Run-Time error '9': Subscript out of range（下标越界）错误，打印按钮原设计逻辑为批量打印所有勾选复选框对应的工作表，原故障代码如下：

Private Sub cmdPrint_Click()

    Dim i As Integer
    Dim cb As MSForms.Control
    Dim SheetArray() As String
        
    i = 0
    'Search form for a checkbox
    For Each cb In Me.Controls
    i = i + 1
    ReDim Preserve SheetArray(i)
        'If the control is a checkbox
        If TypeName(cb) = "CheckBox" Then
        'and the checkbox is checked
            If cb.Value = True Then
            'Add the sheet to the sheet array (sheet name string was already added to the checkbox property caption; see UserForm_initialize)
            SheetArray(i) = cb.Caption
            End If
        End If
    Next cb
    'Print Sheet Array
    Sheets(SheetArray()).PrintOut
    
    Unload Me
End Sub

错误原因 #

代码存在3个核心问题触发下标越界：

• 数组计数逻辑错误：遍历窗体所有控件（包含打印按钮等非复选框控件）时，每遍历一个控件就给数组扩容+1，导致数组中存在大量空字符串元素，传入Sheets()集合时找不到对应名称的工作表
• 数组下标错位：VBA动态数组默认下标从0开始，原代码从i=1开始赋值，数组第0位始终为空值
• 缺少空选中校验：如果用户没有勾选任何复选框，数组全为空值，调用打印方法必然报错

修复方案 #

调整数组计数逻辑，仅在识别到已勾选的复选框时才扩容数组，同时增加空选中校验，修复后完整代码如下：

Private Sub cmdPrint_Click()
    Dim i As Integer
    Dim cb As MSForms.Control
    Dim SheetArray() As String
        
    i = 0
    ' 遍历控件仅识别已勾选的复选框
    For Each cb In Me.Controls
        ' 先判断控件类型和勾选状态，符合条件才存入数组
        If TypeName(cb) = "CheckBox" And cb.Value = True Then
            ReDim Preserve SheetArray(i)
            SheetArray(i) = cb.Caption
            i = i + 1
        End If
    Next cb
    
    ' 校验是否有选中项，避免空数组报错
    If i = 0 Then
        MsgBox "请先选择需要打印的工作表！", vbExclamation
        Exit Sub
    End If
    
    ' 批量打印选中工作表
    Sheets(SheetArray()).PrintOut
    
    Unload Me
End Sub

可选优化：简化初始化代码 #

原初始化代码重复编写20行赋值语句，可通过循环简化，后续调整复选框/工作表数量时更易维护：

Private Sub UserForm_Initialize()
    Dim i As Integer
    For i = 1 To 20
        Me.Controls("CheckBox" & i).Caption = Sheets(i).Name
    Next i
End Sub

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