将大型(~89,000 个元素)数组写入范围

Question

根据某些条件填充数组后，我尝试将两个临时数组写入工作表上的两个不同范围。将我当前的方法与转置数组一起使用，我开始在第 24,392 行之后获得#N/A值。我不确定如何克服Application.Transpose的大小限制。

LastRowA和LastRowB在全球范围内声明为 long 。LastRowA的价值为11,000>，LastRowB为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

除了转置数组返回#N/A之外，一切都按预期工作。

Answer 1

用一列使数组二维

：

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

然后，当您分配值时：

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

那么你不需要Application.Transpose

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

---

同样为了加快速度，完全避免循环：

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