VBA: Adding non-contiguous ranges (not values) to an array-CodePudding

I am trying to build an array of ranges from specific values along the column. I need to work with the cells between the values and this seems like the easiest way to accomplish it. The value is always the same, but how many there are in the column can change. I've found a lot of information on assigning values to an array, or creating an array from a contiguous range of cells, but not to assign specific cells to an array.

Below is the code I've been working on. I get a type mismatch error in the For loop on the 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

CodePudding user response：

There are many ways to do this, as noted in the comments:

Use an array, but you have to size it first (use ReDim):

Dim aRng() As Range

Dim total As Long
total = Application.CountIf(xRng, "*Item Number*")

If total > 0 Then
    ReDim aRng(0 to total - 1)
End If
...
Set aRng(x) = Cell ' objects need Set

Use Union:

Dim rng As Range
For Each Cell In xRng
    If InStr(Cell.Value, "Item Number") > 0 Then    
        If rng Is Nothing Then
            Set rng = Cell
        Else
            Set rng = Union(rng, Cell)
        End If
    End If
Next

Use a Collection:

Dim coll As Collection
Set coll = New Collection

For Each Cell In xRng
   If InStr(Cell.Value, "Item Number") > 0 Then
      coll.Add Cell
   End If
Next

CodePudding user response：

Cell Ranges to Array

Basically, size the array to the number of rows. Do your thing, and resize it to the number of matches using the Preserve keyword.

Sub CellsToArray()
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    ' Keep in mind that the 1 is the column of the used range.
    ' It is not necessarily the same number as the worksheet column.
    Dim rg As Range: Set rg = ws.UsedRange.Columns(1)
    Dim rCount As Long: rCount = rg.Rows.Count
    
    ' Probably too big, but It can't be bigger than 'rCount'.
    ' When done writing, we will resize it.
    Dim Arr() As Range: ReDim Arr(1 To rCount) ' it need not be zero-based
    
    Dim cell As Range
    Dim n As Long
    
    For Each cell In rg.Cells
        ' 'vbTextCompare' will allow case-insensitivity e.g. 'item = ITEM'
        If InStr(1, CStr(cell.Value), "Item Number", vbTextCompare) > 0 Then
            n = n   1
            Set Arr(n) = cell
        End If
    Next cell
    
    If n = 0 Then
        Debug.Print "No items found."
        Exit Sub
    End If
    
    If n < rCount Then ReDim Preserve Arr(1 To n) ' resize to number of matches
            
    For n = 1 To UBound(Arr)
        Debug.Print n, Arr(n).Address(0, 0), Arr(n).Value
    Next n

End Sub

CodePudding user response：

Thank you everyone for your input. It was all very beneficial! I've decided to go with a collection for this one, I think it will be much easier to do what I need to do with it. I've also set up a last row function. For the types of reports I have to generate it will be very beneficial.

    Sub CellsToArray()
    'Objects
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim Cell As Range, xRng As Range
    
    'Collection
    Dim cRng As New Collection
    
    'Variables
    Dim lr As Long, x As Long
    
    'Inialize
    lr = LastRow(ws)
    Set xRng = ws.Range("A1:A" & lr)
    x = 1
    
    'Populate the collection
    For Each Cell In xRng
        If InStr(Cell.Value, "Item Number") > 0 Then
            cRng.Add Cell
            x = x   1
        End If
    Next Cell
            
    For x = 1 To cRng.Count
        Debug.Print cRng(x).Address
    Next x   
End Sub

Function LastRow(ws As Worksheet) As Long
    With ws
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            LastRow = .Cells.Find(What:="*", _
            After:=.Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row
        Else
            LastRow = 1
        End If
    End With
End Function