遍历工作表创建条件值列表时ListBox绑定联合区域报错

核心问题 #

联合区域（UnionRange）是不连续的单元格集合，直接调用.Value返回的是多个独立的区域值集合，而ListBox的.List属性仅支持连续的一维/二维数组，无法解析这种非连续结构，因此会报错。另外原代码还有两处潜在问题：

• 依赖sh.Activate操作，容易引发引用混乱，应该直接通过工作表对象限定单元格引用
• Range("e6").End(xlDown).Row如果E6下方没有数据，会定位到工作表最后一行，导致无效遍历

修复方案一：用数组直接收集符合条件的值（推荐） #

放弃Union，直接遍历单元格时把符合条件的值存入数组，最后赋值给ListBox，逻辑更清晰且避免非连续区域问题：

Private Sub UserForm_Initialize()
    Dim sh As Worksheet
    Dim i As Long, RowNo As Long
    Dim tempArr As Variant
    Dim arrIndex As Long
    
    '初始化数组，预留足够空间
    ReDim tempArr(1 To 1000)
    arrIndex = 0
    
    For Each sh In Worksheets
        If sh.Name = "LISTS" Then Exit For
        
        '避免E6下方无数据的情况，先判断E6是否为空
        If sh.Range("E6").Value <> "" Then
            RowNo = sh.Range("E6").End(xlDown).Row
            '防止End(xlDown)跑到最后一行，做个上限判断
            If RowNo > sh.Cells(sh.Rows.Count, "E").End(xlUp).Row Then
                RowNo = sh.Cells(sh.Rows.Count, "E").End(xlUp).Row
            End If
            
            For i = 1 To RowNo
                If sh.Range("K" & i).Value = "TBD" Then
                    arrIndex = arrIndex + 1
                    tempArr(arrIndex) = sh.Range("K" & i).Value
                End If
            Next i
        End If
    Next sh
    
    '调整数组到实际元素数量
    If arrIndex > 0 Then
        ReDim Preserve tempArr(1 To arrIndex)
        '转成二维数组适配ListBox.List
        lbTBDNAV.List = Application.Transpose(tempArr)
    Else
        '没有符合条件的值时清空列表
        lbTBDNAV.Clear
    End If
End Sub

修复方案二：将联合区域转成连续数组 #

如果坚持要用Union收集区域，需要遍历联合区域的每个子区域，把值提取到连续数组中：

Private Sub UserForm_Initialize()
    Dim sh As Worksheet
    Dim i As Long, RowNo As Long
    Dim UnionRange As Range
    Dim subRng As Range
    Dim tempArr As Variant
    Dim arrIndex As Long
    
    ReDim tempArr(1 To 1000)
    arrIndex = 0
    
    For Each sh In Worksheets
        If sh.Name = "LISTS" Then Exit For
        
        If sh.Range("E6").Value <> "" Then
            RowNo = sh.Range("E6").End(xlDown).Row
            If RowNo > sh.Cells(sh.Rows.Count, "E").End(xlUp).Row Then
                RowNo = sh.Cells(sh.Rows.Count, "E").End(xlUp).Row
            End If
            
            For i = 1 To RowNo
                If sh.Range("K" & i).Value = "TBD" Then
                    If UnionRange Is Nothing Then
                        Set UnionRange = sh.Range("K" & i)
                    Else
                        Set UnionRange = Union(UnionRange, sh.Range("K" & i))
                    End If
                End If
            Next i
        End If
    Next sh
    
    '遍历联合区域的每个子区域，提取值到数组
    If Not UnionRange Is Nothing Then
        For Each subRng In UnionRange.Areas
            For i = 1 To subRng.Rows.Count
                arrIndex = arrIndex + 1
                tempArr(arrIndex) = subRng.Cells(i, 1).Value
            Next i
        Next subRng
        
        ReDim Preserve tempArr(1 To arrIndex)
        lbTBDNAV.List = Application.Transpose(tempArr)
    Else
        lbTBDNAV.Clear
    End If
End Sub

关键优化点 #

• 移除Activate操作，直接通过sh.Range限定工作表，避免跨表引用错误
• 增加对E6单元格是否为空的判断，防止End(xlDown)定位错误
• 用数组存储值，确保传给ListBox的是连续结构，适配.List属性要求

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