Copy Multiple Non-Adjacent Columns To Array

Question

I'm trying to copy multiple non-adjacent (non-contiguous) excel columns to an array but it's not working. Below is what I've tried...

    Public Function Test()    
        Dim sh As Worksheet: Set sh = Application.Sheets("MyWorksheet")
        Dim lr As Long: lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
        Dim r1 As Range: Set r1 = sh.Range("A1:A" & lr)
        Dim r2 As Range: Set r2 = sh.Range("C1:C" & lr)
        Dim rAll As Range: Set rAll = Union(r1, r2)
        'Dim arr() As Variant: arr = Application.Transpose(rAll) <-- Throws Type mismatch error
        'Dim arr As Variant: arr = Application.Transpose(rAll) <-- arr Value = Error 2015
        Dim arr() As Variant: arr = rAll.Value2 ' <-- Only the first column (col A) is loaded.
    End Function

Any help is greatly appreciated!

Answer 1

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.

Answer 2

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

Answer 3

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!

Answer 4

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.