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

将大数组（〜89,000个元素）写入范围

1 个答案: