Copy Multiple Non-Adjacent Columns To Array

Since reading multiple values into an array like arr = rAll.Value2 is only possible in continous ranges, you have to alternatives:

Alternative 1:

Write a function that reads the range values area wise and merge it into one array.

Option Explicit 

Public Function NonContinousColumnsToArray(ByVal NonContinousRange As Range) As Variant
    Dim iArea As Long
    For iArea = 1 To NonContinousRange.Areas.Count - 1
        If NonContinousRange.Areas.Item(iArea).Rows.CountLarge <> NonContinousRange.Areas.Item(iArea + 1).Rows.CountLarge Then
            MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
            Exit Function
        End If
    Next iArea

    Dim ArrOutput() As Variant
    ArrOutput = NonContinousRange.Value2 'read first area into array

    'read all other areas
    For iArea = 2 To NonContinousRange.Areas.Count
        ReDim Preserve ArrOutput(1 To UBound(ArrOutput, 1), 1 To UBound(ArrOutput, 2) + NonContinousRange.Areas.Item(iArea).Columns.CountLarge) As Variant  'resize array

        Dim ArrTemp() As Variant  'read arrea at once into temp array
        ArrTemp = NonContinousRange.Areas.Item(iArea).Value2

        'merge temp array into output array
        Dim iCol As Long
        For iCol = 1 To UBound(ArrTemp, 2)
            Dim iRow As Long
            For iRow = 1 To UBound(ArrTemp, 1)
                ArrOutput(iRow, UBound(ArrOutput, 2) - UBound(ArrTemp, 2) + iCol) = ArrTemp(iRow, iCol)
            Next iRow
        Next iCol
    Next iArea

    NonContinousColumnsToArray = ArrOutput
End Function

So the following example procedure

Public Sub ExampleTest()
    Dim InputRng As Range
    Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))

    Dim OutputArr() As Variant
    OutputArr = NonContinousColumnsToArray(InputRng)

    Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub

would take the following non-continous range Union(Range("A1:A9"), Range("C1:D9")) as input,

^{Image 1: The input range was non-continous A1:A9 and C1:D9.}

merge it into one array OutputArr and write the values as follows

^{Image 2: The merged output array written back into cells.}

Alterantive 2: Using a temporary worksheet …

… to paste the values as continous range, which then can be read into an array at once.

Public Sub ExampleTestTempSheet()
    Dim InputRng As Range
    Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))

    Dim OutputArr() As Variant
    OutputArr = NonContinousColumnsToArrayViaTempSheet(InputRng)

    Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub

Public Function NonContinousColumnsToArrayViaTempSheet(ByVal NonContinousRange As Range) As Variant
    On Error Resume Next
    NonContinousRange.Copy
    If Err.Number <> 0 Then
        MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
        Exit Function
    End If
    On Error GoTo 0

    Dim TempSheet As Worksheet
    Set TempSheet = ThisWorkbook.Worksheets.Add
    TempSheet.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    NonContinousColumnsToArrayViaTempSheet = TempSheet.UsedRange.Value2

    Dim ResetDisplayAlerts As Boolean
    ResetDisplayAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = False
    TempSheet.Delete
    Application.DisplayAlerts = ResetDisplayAlerts
End Function

Note that the alternative 2 is more likely to fail, because of the temporary worksheet. I think alternative 1 is more robust.

Alternative solution via Application.Index() function

Just for fun an alternative solution allowing even a resorted column order A,D,C:

Sub ExampleCall()
'[0]define range
    With Sheet1                   ' reference the project's source sheet Code(Name), e.g. Sheet1
        Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim rng As Range: Set rng = .Range("A1:D" & lr)
    End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1]get data in defined columns order A,C,D
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim data: data = RearrangeCols(rng, "A,D,C")
'[2]write to any target range
    Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub

Help functions called by above main procedure

Function RearrangeCols(rng As Range, ByVal ColumnList As String)
'Purpose: return rearranged column values based on ColumnList, e.g. Columns A,C,D instead of A:D
'[a]assign data to variant array
    Dim v: v = rng
'[b]rearrange columns
    v = Application.Index(v, Evaluate("row(1:" & UBound(v) & ")"), GetColNums(ColumnList))    ' Array(1, 3, 4)
'[c]return rearranged array values as function result
    RearrangeCols = v
End Function

Function GetColNums(ByVal ColumnList As String, Optional ByVal Delim As String = ",") As Variant()
'Purpose: return array of column numbers based on argument ColumnList, e.g. "A,C,D" ~> Array(1, 3, 4)
'[a]create 1-dim array based on string argument ColumnList via splitting
    Dim cols: cols = Split(ColumnList, Delim)
'[b]get the column numbers
    ReDim tmp(0 To UBound(cols))
    Dim i: For i = 0 To UBound(tmp):  tmp(i) = Range(cols(i) & ":" & cols(i)).Column: Next
'[c]return function result
    GetColNums = tmp
End Function

Further solution //Edit as of 2020-06-11

For the sake of completeness I demonstrate a further solution based on an array of arrays (here: data) using the rather unknown double zero argument in the Application.Index() function (see section [2]b):

   data = Application.Transpose(Application.Index(data, 0, 0))

Sub FurtherSolution()
'[0]define range
    With Sheet1                   ' reference the project's source sheet Code(Name), e.g. Sheet1
        Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim rng As Range: Set rng = .Range("A1:D" & lr)
    End With
'[1]assign data to variant array
    Dim v: v = rng
'[2]rearrange columns
    'a) define "flat" 1-dim array with 1-dim column data A,C,D (omitting B!)
    Dim data
    data = Array(aCol(v, 1), aCol(v, 3), aCol(v, 4))
    '=====================
    'b) create 2-dim array
    '---------------------
    data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target range
    Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data

End Sub
Function aCol(DataArr, ByVal colNo As Long) As Variant()
'Purpose: return entire column data as "flat" 1-dim array
With Application
    aCol = .Transpose(.Index(DataArr, 0, colNo))
End With
End Function

Caveat: This 2nd approach seems to be less performant for greater data sets.

Related link

Some pecularities of the Application.Index() function

Thank you PEH, Great explanation which led me to the following solution:

    Function Test()
       Dim sh as Worksheet : set sh = Sheets("MySheet")
       Dim lr as Long : lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
       Dim arr () as Variant
       Dim idx as Long

       ' Delete unwanted columns to ensure contiguous columns...
       sh.Columns("B:B").Delete

       ' Load Array
       arr = Sheet("MySheet").Range("A1:B" & lr).value2

       ' This allows speedy index finds... Note, index(arr, startrow, keycol) 
       ' Will need to use "On Error" to handle key not being found
       idx = WorksheetFunction.match("MyKey", WorksheetFunction.Index(arr, 0, 2), 0)

       ' And then fast processing through the array
       For idx = idx to lr
          if (arr(idx, 2) <> "MyKey") then exit for
          ' do some processing...
       Next idx
   End Function

Thank you again!

The idea behind using arrays is to increase speed. Moving and deleting columns, as well as "for" looping slows you down.

I'm looking for a way to speed up one of my procedures from 120,000 µs to 60,000 or less.

The proposed solutions slow it down to 450,000.