Writing large (~89,000 elements) array to range

Question

After populating my arrays based on some criteria I am attempting to write two temporary arrays to two different ranges on the worksheet. Using my current method with the transposed arrays I begin to get #N/A values after row 24,392. I'm not sure how to get past the size limitations of Application.Transpose.

LastRowA and LastRowB are declared globally as long. The value of LastRowA is >11,000 and LastRowB is >80,000

Sub Test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'call subs to find last rows for each sheet
LastRowASub
LastRowBSub

Dim i As Long
Dim j As Long
Dim x As Double
Dim y As Double

Dim Arr1() As Variant
Dim Arr2() As Variant
Dim Temp1() As String
Dim Temp2() As String
ReDim Arr1(1 To LastRowA - 1, 3)
ReDim Arr2(1 To LastRowB - 1)
ReDim Temp1(1 To LastRowB - 1)
ReDim Temp2(1 To LastRowB - 1)

'populate first array
For x = 1 To LastRowA - 1
    Arr1(x, 1) = sheet1.Range("k" & x + 1)
    Arr1(x, 2) = sheet1.Range("c" & x + 1)
    Arr1(x, 3) = sheet1.Range("a" & x + 1)
Next x

'populate second array
For y = 1 To LastRowB - 1
    Arr2(y, 1) = sheet2.Range("f" & y + 1)
Next y

'populate two temporary arrays based on matching between arrays 1 and 2
For i = 1 To UBound(Arr2)
    For j = 1 To UBound(Arr1)
        If Arr1(j, 1) = Arr2(i, 1) And Not IsEmpty(Arr1(j, 2)) Then
            Temp1(i) = Arr1(j, 2)
            Temp2(i) = Arr1(j, 3)
        End If
    Next j
Next i

'write temp arrays to sheet2
sheet2.Range("C2:C" & ExtLRow) = Application.Transpose(Temp1)
sheet2.Range("G2:G" & ExtLRow) = Application.Transpose(Temp2)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Everything is working as expected other than the transposed arrays returning #N/A.

you should debug the values in your arrays Temp1 and Temp2 , from element 25,000 and after. I am using Transpose for arrays with 150K rows, and it's working fine — Shai Rado
– Shai Rado, Commented Jul 17, 2019 at 19:04

Scott Craner · Accepted Answer · 2019-07-17 19:15:40Z

Make the arrays 2 dimensional with one column:

ReDim Temp1(1 To LastRowB - 1,1 to 1)
ReDim Temp1(1 To LastRowB - 1,1 to 1)

Then when you assign the values:

Temp1(i,1) = Arr1(j, 2)
Temp2(i,1) = Arr1(j, 3)

Then you do not need the Application.Transpose

sheet2.Range("C2:C" & ExtLRow) = Temp1
sheet2.Range("G2:G" & ExtLRow) = Temp2

Also to speed things up avoid the loops altogether:

Sub Test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'call subs to find last rows for each sheet
LastRowASub
LastRowBSub

Dim i As Long
Dim j As Long
Dim x As Double
Dim y As Double

Dim Arr1() As Variant
Dim Arr2() As Variant
Dim Temp1() As Variant
Dim Temp2() As Variant

ReDim Temp1(1 To LastRowB - 1, 1 To 1)
ReDim Temp2(1 To LastRowB - 1, 1 To 1)

'populate first array
Arr1 = Sheet1.Range("A2:K" & lastrowa).Value


'populate second array
Arr2 = sheet2.Range("F2:F" & LastRowB).Value

'populate two temporary arrays based on matching between arrays 1 and 2
For i = 1 To UBound(Arr2, 1)
    For j = 1 To UBound(Arr1, 1)
        If Arr1(j, 11) = Arr2(i, 1) And Not IsEmpty(Arr1(j, 3)) Then
            Temp1(i, 1) = Arr1(j, 3)
            Temp2(i, 1) = Arr1(j, 1)
        End If
    Next j
Next i

'write temp arrays to sheet2
sheet2.Range("C2:C" & ExtLRow).Value = Temp1
sheet2.Range("G2:G" & ExtLRow).Value = Temp2

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Collectives™ on Stack Overflow

Writing large (~89,000 elements) array to range

1 Answer 1

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Related