Adding non contiguous rows of data to an array by means of areas

Hello,

I have a data set where users can select entire non contiguous in order to print the selected data on a special form, so I am trying to use 'areas' to join the non contiguous row selections into an array.

I have the following code that works but I'm getting the feeling there must be a better way.

Sub test()

Dim myRange As Range
Dim myAreasCount As Long
Dim myArray() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim iCount1 As Long
Dim iCount2 As Long
Dim myRow As Long
Dim myAreaRowsCount As Long

Selection.EntireRow.Select

myAreasCount = Selection.Areas.Count

iCount1 = 1

For i = 1 To myAreasCount
    myAreaRowsCount = Selection.Areas(i).Rows.Count
    For j = 1 To myAreaRowsCount
        iCount1 = iCount1 + 1
    Next
Next

ReDim myArray(iCount1 - 1, 7)

iCount2 = 1
For i = 1 To myAreasCount
    myAreaRowsCount = Selection.Areas(i).Rows.Count
    For j = 1 To myAreaRowsCount
        For k = 1 To 7
            myArray(iCount2, k) = Selection.Areas(i).Rows(1).Cells(j, k)
            Debug.Print myArray(iCount2, k)
            Debug.Print myArray(1, 1)
        Next
        iCount2 = iCount2 + 1
    Next
Next
End Sub

I'm using the first For loop to determine the total number of rows selected and thus the necessary size of the array, keeping in mind that each area may have contiguous rows within it.

The second For loop is pretty much a repeat of the first For loop and adds the data of the selected rows to the array one cell at a time.

There's got to be a better way!


TV

Hi TV,
try this

Sub test2()
Dim myArray
With Sheets("Sheet2")
    .UsedRange.Clear
    Intersect(Selection.EntireRow, Range("A:G")).Copy .Range("A1")
    myArray = .Range("A1").CurrentRegion.Value
End With
MsgBox UBound(myArray) & "  " & UBound(myArray, 2)
'Range("J1").Resize(UBound(myArray), UBound(myArray, 2)).Value = myArray
End Sub

Nilem, thanks for you response. I also considered temporarily moving the data to another sheet, but I was looking for a solution that did not rely on that.

TV

then maybe so

Sub test3()
Dim r As Range, x, y(), i&, j&, k&
With Intersect(Selection.EntireRow, Range("A:G"))
    ReDim y(1 To ActiveSheet.UsedRange.Rows.Count, 1 To .Columns.Count)
    For Each r In .Areas
        x = r.CurrentRegion.Value
        For i = 1 To UBound(x)
            k = k + 1
            For j = 1 To UBound(x, 2)
                y(k, j) = x(i, j)
            Next j
        Next i
    Next r
End With
Range("J1").Resize(k, UBound(y, 2)).Value = y()
End Sub