Splitting an Array with many Elements into 4 Parts for Output to a Worksheet

user_4213982 0
Viewed 43

There are some questions about splitting arrays but in my case something goes wrong when I want to output the arrays onto the Worksheet. Also, my solution seems a bit complicated.

My goal is to split a 1-dimensional array with 2.5 mln elements in 4 parts to be able to easily output it to a Worksheet (625,000 rows, 4 columns).

SomeSub() is where the data originates, in this case "i Mod 99" generates some "random" numbers to see some output on the Worksheet. SomeSub() calls the sub SplitArray() which is very the splitting happens. I only have data in a 1-dimensional array but I thought I need to use a 2-dimensional one so that I can get the values from columns into rows by transposing them. Not sure this is actually needed but it works to some degree.

Sub SomeSub()
Dim i As Long
Dim bigarr(1, 2500000) As Integer
Dim timing As Single

timing = Timer
For i = 1 To 2500000
   bigarr(1, i) = i Mod 99
Next i
Call SplitArray(bigarr)
Debug.Print Format(Timer - timing, "0.0") & " seconds"
End Sub

Sub SplitArray(ByRef arr0() As Integer)
Dim i As Long
Dim arr1(1, 625000) As Integer
Dim arr2(1, 625000) As Integer
Dim arr3(1, 625000) As Integer
Dim arr4(1, 625000) As Integer

For i = 1 To 625000:        arr1(1, i) = arr0(1, i):           Next i
For i = 625001 To 1250000:  arr2(1, i - 625000) = arr0(1, i):  Next i
For i = 1250001 To 1875000: arr3(1, i - 1250000) = arr0(1, i): Next i
For i = 1875001 To 2500000: arr4(1, i - 1875000) = arr0(1, i): Next i

Dim vektor As Variant
Worksheets("Output").Select

vektor = Application.WorksheetFunction.Transpose(arr1)
Range(Cells(11, 1), Cells(625010, 1)).Value = vektor

vektor = Application.WorksheetFunction.Transpose(arr2)
Range(Cells(11, 2), Cells(625010, 2)).Value = vektor

vektor = Application.WorksheetFunction.Transpose(arr3)
Range(Cells(11, 3), Cells(625010, 3)).Value = vektor

vektor = Application.WorksheetFunction.Transpose(arr4)
Range(Cells(11, 4), Cells(625010, 4)).Value = vektor
End Sub

The problem is that my approach works only until row 35186 but not until row 625,010.

NA values after 35186 rows

Currently the whole procedure takes about 1.9 seconds using 1 thread. This is usually fast enough but a quicker or simpler solution to splitting a "long array" would also be appreciated.

vba excel arrays
2 Answers

Change your arrays to be vertical instead of horizontal and you can avoid Application.Transpose which has a limit to the number of items it allows:

Sub SplitArray(ByRef arr0() As Integer)
    Dim i As Long
    Dim arr1(625000, 1) As Integer
    Dim arr2(625000, 1) As Integer
    Dim arr3(625000, 1) As Integer
    Dim arr4(625000, 1) As Integer
    
    For i = 1 To 625000:        arr1(i, 1) = arr0(1, i):           Next i
    For i = 625001 To 1250000:  arr2(i - 625000, 1) = arr0(1, i):  Next i
    For i = 1250001 To 1875000: arr3(i - 1250000, 1) = arr0(1, i): Next i
    For i = 1875001 To 2500000: arr4(i - 1875000, 1) = arr0(1, i): Next i
    
    With Worksheets("Output")
    
    .Range(.Cells(11, 1), .Cells(625010, 1)).Value = arr1
    
    .Range(.Cells(11, 2), .Cells(625010, 2)).Value = arr2
    
    .Range(.Cells(11, 3), .Cells(625010, 3)).Value = arr3
    
    .Range(.Cells(11, 4), .Cells(625010, 4)).Value = arr4

    End With
End Sub

But you really only need one output array with 4 columns:

Sub SplitArray(ByRef arr0() As Integer)
    Dim i As Long
    Dim arr1(625000, 4) As Integer

    
    For i = 1 To 625000:        arr1(i, 1) = arr0(1, i):           Next i
    For i = 625001 To 1250000:  arr1(i - 625000, 2) = arr0(1, i):  Next i
    For i = 1250001 To 1875000: arr1(i - 1250000, 3) = arr0(1, i): Next i
    For i = 1875001 To 2500000: arr1(i - 1875000, 4) = arr0(1, i): Next i
    
    With Worksheets("Output")
        .Range(.Cells(11, 1), .Cells(625010, 4)).Value = arr1
    End With
    
End Sub
user_48515900

Split a 1D Array

Simple

  • The GetSplitOneD function will return the columns in a 2D one-based array whose values can easily be written (copied) to a range e.g.:

    rg.Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data      

Sub GetSplitOneDtest()
    
    Dim Timing As Double: Timing = Timer
    
    Const nCount As Long = 2500000
    Const ColumnsCount As Long = 4
    Const dName As String = "Output"
    Const dFirstCellAddress As String = "A2"
    
    ' Reference the workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim n As Long
    
    ' Create the source (sample) array i.e. return the numbers
    ' from 1 to 'nCount' in a 1D one-based array.
    Dim sArr() As Variant: ReDim sArr(1 To nCount)
    For n = 1 To nCount
        sArr(n) = n
    Next n
    
    ' Using the 'GetSplitOneD' function, return the split values
    ' from the source array in the destination array ('dData'),
    ' a 2D one-based array.
    Dim dData() As Variant: dData = GetSplitOneD(sArr, ColumnsCount)
    
    ' Write the destination rows count to a variable ('drCount').
    Dim drCount As Long: drCount = UBound(dData, 1)
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    
    ' Calculate the destination clear rows count ('dcrCount'),
    ' the number of rows to be cleared below the destination ranges.
    Dim dcrCount As Long: dcrCount = dws.Rows.Count - dfCell.Row - drCount + 1
    
    ' Write the values from the destination array to the destination ranges.
    With dfCell.Resize(, ColumnsCount) ' reference the first row
        .Resize(drCount).Value = dData ' write
        .Resize(dcrCount).Offset(drCount).Clear ' clear below
    End With
    
    Debug.Print Format(Timer - Timing, "0.000") & " seconds"
    
    ' Inform.
    MsgBox "Data split.", vbInformation
    
End Sub

Function GetSplitOneD( _
    SourceOneD() As Variant, _
    ByVal ColumnsCount As Long) _
As Variant()
    
    Dim sCount As Long: sCount = UBound(SourceOneD) - LBound(SourceOneD) + 1
    
    Dim drCounts() As Long: ReDim drCounts(1 To ColumnsCount)
    Dim drCount As Long: drCount = Int(sCount / ColumnsCount)
    Dim Remainder As Long: Remainder = sCount Mod ColumnsCount
    If Remainder > 0 Then
        drCount = drCount + 1
        drCounts(ColumnsCount) = drCount - ColumnsCount + Remainder
    Else
        drCounts(ColumnsCount) = drCount
    End If
    
    Dim c As Long
    
    For c = 1 To ColumnsCount - 1: drCounts(c) = drCount: Next c
        
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
    Dim s As Long: s = LBound(SourceOneD)
    
    Dim dr As Long
    
    For c = 1 To ColumnsCount
        For dr = 1 To drCounts(c)
            dData(dr, c) = SourceOneD(s)
            s = s + 1
        Next dr
    Next c
    
    GetSplitOneD = dData
    
End Function

More Flexible

  • The GetJaggedSplitOneD function will return the columns in a jagged array containing as many 2D one-based one-column arrays as there are columns. Then you could write each column to another place instead of writing them next to each other. In the test sub, you could change the value of the dcGap constant determining how many empty columns should be in-between. If you don't need this additional functionality, use the first function since it's a little bit faster.
Sub GetJaggedSplitOneDtest()
    
    Dim Timing As Double: Timing = Timer
    
    ' Define constants.
    Const nCount As Long = 2500000
    Const ColumnsCount As Long = 4
    Const dName As String = "Output"
    Const dFirstCellAddress As String = "A2"
    Const dcGap As Long = 2 ' empty columns in-between
    
    ' Reference the workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim n As Long
    
    ' Create the source (sample) array i.e. return the numbers
    ' from 1 to 'nCount' in a 1D one-based array.
    Dim sArr() As Variant: ReDim sArr(1 To nCount)
    For n = 1 To nCount
        sArr(n) = n
    Next n
    
    ' Using the 'GetJaggedSplitOneD' function, return the split values
    ' from the source array in the destination array ('dJAG'), a jagged array
    ' containing 4 ('ColumnsCount') same-sized 2D one-based one-column arrays.
    Dim dJag() As Variant: dJag = GetJaggedSplitOneD(sArr, ColumnsCount)
    
    ' Write the destination rows count to a variable ('drCount').
    Dim drCount As Long: drCount = UBound(dJag(1), 1)
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    
    ' Calculate the destination clear rows count ('dcrCount'),
    ' the number of rows to be cleared below the destination ranges.
    Dim dcrCount As Long: dcrCount = dws.Rows.Count - dfCell.Row - drCount + 1
    
    ' Write the values from the destination array to the destination ranges.
    For n = 1 To ColumnsCount
        With dfCell
            .Resize(drCount).Value = dJag(n) ' write
            .Resize(dcrCount).Offset(drCount).Clear ' clear below
        End With
        Set dfCell = dfCell.Offset(, dcGap + 1)
    Next n
    
    Debug.Print Format(Timer - Timing, "0.000") & " seconds"
    
    ' Inform.
    MsgBox "Data split.", vbInformation
    
End Sub

Function GetJaggedSplitOneD( _
    SourceOneD() As Variant, _
    ByVal ColumnsCount As Long) _
As Variant()
    
    Dim sCount As Long: sCount = UBound(SourceOneD) - LBound(SourceOneD) + 1
    
    Dim drCounts() As Long: ReDim drCounts(1 To ColumnsCount)
    Dim drCount As Long: drCount = Int(sCount / ColumnsCount)
    Dim Remainder As Long: Remainder = sCount Mod ColumnsCount
    If Remainder > 0 Then
        drCount = drCount + 1
        drCounts(ColumnsCount) = drCount - ColumnsCount + Remainder
    Else
        drCounts(ColumnsCount) = drCount
    End If
    
    Dim c As Long
    
    For c = 1 To ColumnsCount - 1: drCounts(c) = drCount: Next c
        
    Dim dJag() As Variant: ReDim dJag(1 To ColumnsCount)
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To 1)
    Dim s As Long: s = LBound(SourceOneD)
    
    Dim dr As Long
    
    For c = 1 To ColumnsCount
        dJag(c) = dData
        For dr = 1 To drCounts(c)
            dJag(c)(dr, 1) = SourceOneD(s)
            s = s + 1
        Next dr
    Next c
    
    GetJaggedSplitOneD = dJag
    
End Function
user_98140690
Related