Split an array over multiple sheets?

[TheWennerWoman]

Thanks to @Alex Blakenburg I have the following code which works perfectly on my dataset

Sub create_journal_arr()
Dim LastRow As Long
Dim a As Long
Dim b As Long
Dim arrA As Variant, arrB As Variant
Dim wsA As Worksheet
Dim rngA As Range, rngB As Range

Set wsA = ActiveSheet
With wsA
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rngA = .Range(.Cells(2, "A"), .Cells(LastRow, "H"))
    arrA = rngA.Value2
End With

Set rngB = Sheet2.Range("A2")
ReDim arrB(1 To UBound(arrA) * 7, 1 To 4)

b = 1
For a = 1 To UBound(arrA)
arrB(b, 1) = "C5678"
arrB(b, 2) = "103000"
arrB(b, 3) = arrA(a, 3)
arrB(b, 4) = arrA(a, 2)
b = b + 1

If arrA(a, 4) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "145444"
    arrB(b, 3) = arrA(a, 4)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 5) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "173000"
    arrB(b, 3) = arrA(a, 5)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 6) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "199000"
    arrB(b, 3) = arrA(a, 6)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 7) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "212000"
    arrB(b, 3) = arrA(a, 7)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 8) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "255666"
    arrB(b, 3) = arrA(a, 8)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
Next

' Write out Array
rngB.Resize(b, UBound(arrB, 2)).Value = arrB

End Sub

A victim of our own success, this code is so efficient that the world and his wife are now using it and we now have a situation where the array has over 100,000 records - this code generates the output perfectly and in seconds but loading that dataset into an accounts package is timing out (too many records).

Is it possible to modify this code so it pushes, say 25,000 records onto Sheet2, the next 25,000 records into Sheet3 etc etc?

 

[Legacy 143009]

You can rearrange this line:

rngB.Resize(b, UBound(arrB, 2)).Value = arrB

like this:

rngB.Resize(b/2, UBound(arrB, 2)).Value = arrB
Set rngB = Sheet3.Range("A2")
rngB.Resize(b-(b/2), UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & (b/2)+1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

It's a bit sketchy but must work

 

[TheWennerWoman]

You can rearrange this line:

rngB.Resize(b, UBound(arrB, 2)).Value = arrB

like this:

rngB.Resize(b/2, UBound(arrB, 2)).Value = arrB
Set rngB = Sheet3.Range("A2")
rngB.Resize(b-(b/2), UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & (b/2)+1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

It's a bit sketchy but must work

Thanks for that - but on Sheet3 all I have is #VALUE in each cell.

Plus is this just splitting the array into 2?

 

[Legacy 143009]

Plus is this just splitting the array into 2?

Yes indeed.

Ok, I think you have odd number of rows. Declare a Long c at the very beginning. Then:

c = b / 2
rngB.Resize(c, UBound(arrB, 2)).Value = arrB
Set rngB = Sheet3.Range("A2")
rngB.Resize(b - c, UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & c + 1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

 

[TheWennerWoman]

Yes indeed.

Ok, I think you have odd number of rows. Declare a Long c at the very beginning. Then:

c = b / 2
rngB.Resize(c, UBound(arrB, 2)).Value = arrB
Set rngB = Sheet3.Range("A2")
rngB.Resize(b - c, UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & c + 1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

Run Time Error 1004

Application-defined or Object-defined error on

 

[Legacy 143009]

Ok, try to set Sheet3 with worksheet name. I can't think of any other solutions:

c = b / 2
rngB.Resize(c, UBound(arrB, 2)).Value = arrB
Set rngB = Worksheets("Sheet3").Range("A2")
rngB.Resize(b - c, UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & c + 1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

 

[TheWennerWoman]

Ok, try to set Sheet3 with worksheet name. I can't think of any other solutions:

c = b / 2
rngB.Resize(c, UBound(arrB, 2)).Value = arrB
Set rngB = Worksheets("Sheet3").Range("A2")
rngB.Resize(b - c, UBound(arrB, 2)).Value = Application.Index(arrB, Evaluate("row(" & c + 1 & ":" & b & ")"), Evaluate("column(1:" & UBound(arrB, 2) & ")"))

That works, many thanks!

 

[Legacy 143009]

You are welcome