VBA技术问题：将非连续单元格区域（非值）存入数组

我需要从列中提取所有包含“Item Number”的单元格存入数组，以此处理这些单元格之间的内容，但列中该值的出现次数不固定。编写的代码在aRng(x) = Cell语句处出现类型不匹配错误，原代码如下：

Sub CellsToArray()
'Objects
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Cell As Range, xRng As Range

'Arrays
Dim aRng() As Variant

'Variables
Dim LastRow As Long, x As Long

'Inialize
LastRow = ws.UsedRange.rows.Count
Set xRng = ws.Range("A1:A" & LastRow)
x = 0

'Populate the array
For Each Cell In xRng
    If InStr(Cell.Value, "Item Number") > 0 Then
        aRng(x) = Cell
        x = x + 1
    End If
Next Cell
        
For x = 0 To UBound(aRng)
    Debug.Print aRng(x).Address
Next x
End Sub

错误原因 #

1. 直接给Variant数组赋值Range对象时，未使用Set关键字（对象类型赋值必须通过引用）；
2. 数组未初始化大小，直接索引赋值会触发越界或类型错误；
3. Variant数组存储对象时，虽语法允许，但未明确类型易导致匹配问题。

修正方案：存储Range对象的动态数组 #

以下是修正后的代码，解决类型不匹配问题并完善数组逻辑：

Sub CellsToArray()
'Objects
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Cell As Range, xRng As Range

'Arrays - 声明为Range对象数组，明确存储类型
Dim aRng() As Range

'Variables
Dim LastRow As Long, x As Long

'Inialize
LastRow = ws.UsedRange.Rows.Count
Set xRng = ws.Range("A1:A" & LastRow)
x = 0

'Populate the array
For Each Cell In xRng
    If InStr(Cell.Value, "Item Number") > 0 Then
        x = x + 1
        '动态扩容数组，Preserve保留已有元素
        ReDim Preserve aRng(1 To x)
        '对象赋值必须使用Set关键字
        Set aRng(x) = Cell
    End If
Next Cell
        
'遍历数组输出单元格地址，增加空数组判断避免报错
If x > 0 Then
    For x = 1 To UBound(aRng)
        Debug.Print aRng(x).Address
    Next x
Else
    Debug.Print "未找到包含""Item Number""的单元格"
End If
End Sub

关键修正点 #

• 将数组类型从Variant改为Range，明确存储对象类型；
• 每次找到匹配单元格时，先递增计数器再用ReDim Preserve动态扩容数组；
• 使用Set关键字给数组元素赋值Range对象；
• 增加空数组判断，避免无匹配时UBound(aRng)触发错误。

可选方案：存储单元格地址字符串 #

如果不需要直接操作Range对象，可以先收集单元格地址到字符串数组，后续按需转为Range对象，适合批量处理场景：

Sub CellsAddressToArray()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Cell As Range, xRng As Range
Dim addrArr() As String
Dim LastRow As Long, x As Long

LastRow = ws.UsedRange.Rows.Count
Set xRng = ws.Range("A1:A" & LastRow)
x = 0

For Each Cell In xRng
    If InStr(Cell.Value, "Item Number") > 0 Then
        x = x + 1
        ReDim Preserve addrArr(1 To x)
        addrArr(x) = Cell.Address
    End If
Next Cell

If x > 0 Then
    '将地址数组合并为单个Range对象
    Dim targetRng As Range
    Set targetRng = ws.Range(Join(addrArr, ","))
    Debug.Print "匹配单元格区域：" & targetRng.Address
    
    '遍历地址数组输出单个地址
    For x = 1 To UBound(addrArr)
        Debug.Print "匹配单元格：" & addrArr(x)
    Next x
End If
End Sub

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