1

I have a dataset that contains data in different ranges on a source file that I would like to combine into a single range and copy/paste into a destination file. While union works, I need to run this on a hundred worksheets and it's taking way too long to do the union/copy/paste. I'd like to see if I would get a performance boost from converting into an array.

I have tried doing so by using union to combine the ranges, but i am not able to get the array to initialize to more than one column in doing so. Not sure what I'm doing wrong?

here's an example.

sub CopyData()
dim LastR as long
dim dataArr as variant

with SourceWS
    LastR = .cells(.rows.count,1).end(xlup).row

    dataArr = .union(.range("A8:A" & LastR), _
                     .range("C8:C" & LastR), _
                     .range("H8:H" & LastR))

end with

DestWS.range("A1").resize(ubound(dataArr,1), ubound(dataArr,2)) = dataArr

end sub
Monduras
  • 47
  • 8
  • You can't read the `Value` from a non-contiguous range. – Tim Williams Nov 13 '21 at 04:37
  • is there a way to get around this? my code is very slow otherwise ;/ – Monduras Nov 13 '21 at 04:47
  • Is this [Non-contiguous named range into an array](https://stackoverflow.com/questions/25365547/non-contiguous-named-range-into-an-array-then-into-row-in-different-sheet) what you want? – Siddharth Rout Nov 13 '21 at 05:11
  • 1
    Also an answer by @TimWilliams [Get values from union of non-contiguous ranges into array](https://stackoverflow.com/questions/18993915/get-values-from-union-of-non-contiguous-ranges-into-array-with-vba-with-a-simple) might also help – Siddharth Rout Nov 13 '21 at 05:17
  • @SiddharthRout - thanks forgot about that one... – Tim Williams Nov 13 '21 at 05:50

3 Answers3

2

I received some help with this on a different forum. The following accomplishes what I'm trying to do:

Sub CombineRanges()

    Dim MyArr() As Variant
    Dim MyRows as Variant

    MyRows = Evaluate("ROW(1:20)")
    MyArr = Application.Index(Columns("A:H"), MyRows, Array(1, 3, 8))
    Range("Z1").Resize(UBound(MyArr, 1), UBound(MyArr, 2)).Value2 = MyArr

End Sub
Jeremy Caney
  • 7,102
  • 69
  • 48
  • 77
Monduras
  • 47
  • 8
1

The approach in section A) Double zero-indexing is meant as a reply to your own answer with the intention to demonstrate another relatively unknown variation of Application.WorksheetFunction.Index() and focussing upon your initial Union range.

If you dispose, however of the newer dynamic array features of MS 365, you can find a fast, flexible and straight-forward approach in section B) Flexible Worksheet related evaluation (late post as of 2021-11-18).

A) Double zero-indexing

You posted a solution creating a great datafield array including a lot of unneeded columns in between which you remove via Application.Index() keeping only the column numbers in Array(1,3,8). You might be interested in this overview of some pecularities of Application.Index() I wrote over 3 years ago.

Instead of removing all unneeded columns from a datafield array, you could do the reverse starting from the posted Union range:

  • collect only the existing area data (single columns of identical lengths assumed) in a so called jagged array (aka array of arrays or array container) and
  • unite all to a coherent 2-dim array via Application.Index(data, 0, 0) - note the double zero arguments here!
Option Explicit

Sub CopyData()
'Site: https://stackoverflow.com/questions/69951489/how-can-i-add-different-ranges-to-an-array
'Note: needs identical number of elements in each area of one column!
'[0]build example Union range as in original post
    With Sheet1               ' change as needed
        Dim lastR As Long
        lastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim u As Range
        Set u = Union(.Range("A8:A" & lastR), _
                      .Range("C8:C" & lastR), _
                      .Range("H8:H" & lastR))
    End With

'[1]assign "flat" (transposed) column data to a jagged array (array container)
    Dim data
    With Application.WorksheetFunction     ' preferrable inst/of Application only
        data = Array(.Transpose(u.Areas(1)), .Transpose(u.Areas(2)), Application.Transpose(u.Areas(3)))
    End With
'[2]unite data as 2-dim array
    data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target (e.g. Sheet2)
    Sheet2.Range("A1").Resize(UBound(data, 1), UBound(data, 2)) = data
End Sub

Caveat

Note that since vers. 2016 transposing with Application.WorksheetFunction.Transpose overcomes the limit of 65536 (2 ^ 16) if applied to ranges; unfortunably it rests unchanged if applied upon arrays.


B) Flexible worksheet-related evaluation // (added 2021-11-18)

Fast approach based on version MS 365

As in section A) I assume non-adjacent single columns. The main logic lies in the built formula string capable to get a 2-dim array in the order defined by your initial Union range. In your example the number of areas (expressed as array) and the area addresses might result in something like

    =LET(data,CHOOSE({1,2,3},A8:A20,C8:C20,H8:H20),data)

where CHOOSE via {1,2,3} reflects the wanted order of the listed columns after another evaluation applying ARRAYTOTEXT upon a SEQUENCE.


Sub CopyDataNew()
    Dim t As Double: t = Timer
'[0]build example Union range as in original post
    With Sheet1               ' change as needed
        Dim lastR As Long
        lastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim u As Range
        Set u = Union(.Range("A8:A" & lastR), _
                      .Range("C8:C" & lastR), _
                      .Range("H8:H" & lastR))
'[1]a) get sequence string, e.g. "{1,2,3}" (note "."-prefix of .Evaluate!)
    Dim arrText As String
    arrText = .Evaluate("ARRAYTOTEXT(SEQUENCE(1," & u.Areas.Count & ",1),1)")
'[1]b) get formula string,
    Dim myFormula As String
    myFormula = "=LET(data,CHOOSE(" & arrText & "," & u.Address(False, False) & "),data)"
    Debug.Print myFormula
'[1]c) execute worksheet related evaluation (fully qualifying union addresses)
    Dim data
    data = .Evaluate(myFormula)
'[2]write to any target range
    With Sheet2                  
    .Range("A2").Resize(UBound(data, 1), UBound(data, 2)) = data
''   or enter formula into sheet to display as spill range
'    .Range("A2").Formula2 = myFormula
    End With
    
    Debug.Print Format(Timer - t, "0.00 secs needed!")

End Sub

Hint A worksheet related evaluation - e.g. Sheet1.Evaluate(myFormula) - has the advantage that any internal range references are automatically fully qualified.

T.M.
  • 9,436
  • 3
  • 33
  • 57
  • how interesting. i am new to using index in this way - i wonder if it will also decrease the processing time. One question - for some reason when I tried Application.WorksheetFunction.Index I got a mismatch error. Only when I removed worksheetfunction did it work as intended. Do you know why this might be happening? – Monduras Nov 17 '21 at 01:02
  • Appreciate feedback. I chose this approach to demonstrate how to profit from the existing union areas in your given example. a) Yes, it can be time consuming for greater range sizes. You can easily test with `Dim t as double`, `t = Timer` to start and check via `Debug.Print Format(Timer - t, "0.00 secs needed")` b) I corrected the Union assignment of column C to `.Range("C8:C" & lastR), ...` in above code, as this approach needs one column areas (of same length). c) No, my MS 365 version didn't raise any error. There are differences in result error checking, though. @Monduras – T.M. Nov 17 '21 at 09:02
  • @Monduras Fyi Added a fast & flexible approach (vers. MS 365) which btw has no needs of transposing. - Feel free to accept your preferred answer by ticking the green checkmark and/or to upvote any helpful post you got here. – T.M. Nov 18 '21 at 20:17
  • 1
    thanks, i'll choose your answer as it's more complete and provides a detailed analysis! – Monduras Nov 19 '21 at 13:59
0

Get Range Columns

  • This is just a study of OP's answer which is more complicated (RowsArray) than presented. The function GetRangeColumns is what to take away from it.
  • The test procedure should remove any confusion about how to use the function. The test procedure is written for the workbook containing this code where both worksheets reside (source workbook and destination workbook are the same). So there will need to be a few changes to adapt this to be used in a loop (multiple source workbooks, one destination workbook).
Option Explicit

Sub GetRangeColumnsTEST()
' Needs 'GetRangeColumns'.
    Const ProcTitle As String = "Get Range Columns Test"
    
    ' Source
    Const sName As String = "Sheet1"
    Const sCols As String = "A:H"
    Const slrCol As String = "A"
    Const sfRow As Long = 8
    Dim iCols As Variant: iCols = Array(1, 3, 8)
    ' By using e.g. 'iCols = Array(1, 3, 8, 4, 3)' it is proven that the order
    ' of the columns doesn't matter ('4') and that you can repeat columns ('3').
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data in column range
    Dim scrg As Range: Set scrg = sws.Columns(sCols)
    
    ' Array
    Dim Data As Variant: Data = GetRangeColumns(scrg, sfRow, slRow, iCols)
    If IsEmpty(Data) Then Exit Sub ' see message in the Immediate window.
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1), UBound(Data, 2))
    drg.Value = Data
    
    ' Information
    MsgBox "Columns written.", vbInformation, ProcTitle

End Sub

Function GetRangeColumns( _
    ByVal ColumnsRange As Range, _
    ByVal FirstRow As Long, _
    ByVal LastRow As Long, _
    ByVal ColumnsArray As Variant) _
As Variant
    Const ProcName As String = "GetRangeColumns"
    On Error GoTo ClearError

    Dim RowsArray As Variant
    RowsArray = Evaluate("ROW(" & FirstRow & ":" & LastRow & ")")
    GetRangeColumns _
        = Application.Index(ColumnsRange, RowsArray, ColumnsArray)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function
VBasic2008
  • 44,888
  • 5
  • 17
  • 28