[已解决]多个工作表的条件区域内容赋值给数组

DZ稻草人

• 多个工作表，每个工作表要选择的区域不同，根据条件定位。
• 附件里的代码是在多个工作表内根据条件选择不同的区域，每循环一次给数组赋值一次，再接着将数组的值写到指定的区域。
• 我现在想在循环的时候先全部都赋值给数组存储起来，最后再一次性把数组里的值写到指定的区域。
  

还请大家多多指教，非常感谢。

Private Sub CommandButton1_Click() 'Sn,Sn0为填充序列号的变量名。SSn为Sheet表的变量名。Rng - Rng1为区域变量名。
Dim Sn, Sn0 As Long
Dim SSn As Long
Dim Rng, Rng0, Rng1 As Range
Dim Arr()
Sn2 = 0
For SSn = 1 To 16 Step 2
Set Rng = Sheets(SSn).Range("A" & Sheets(SSn).Rows("1" & ":" & Sheets(SSn).[A65535].End(xlUp).Row).Find("65型材", after:=Sheets(SSn).Range("A1")).Row).CurrentRegion
Set Rng0 = Rng.Offset(2, 1).Resize(Rng.Offset(2, 1).Rows.Count - 4, Rng.Offset(2, 1).Columns.Count - 2)
Set Rng1 = Sheets("窗型单价汇总表").Range("B65535").End(xlUp).Rows.Offset(1, 0)
Arr = Rng0.Value
Rng1.Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
Next
GoTo P
P:
For Sn = 6 To [B65535].End(xlUp).Row
Range("A" & Sn) = Sn0 + 1
Sn0 = Sn0 + 1
Next
ActiveWindow.ScrollRow = 1
[A6].Select
End Sub

最佳答案

月排行榜 / 总排行榜

changking123

2022-10-18 22:03

感觉这种比较少的数据量没有必要，如果非要一个数组一次性填充到工作表的话可以试一下用下面的代码。估计运算速度也不会快多少，懒得试了。
Private Sub CommandButton1_Click()
Dim Sn&, Sn0&, SSn&, i&, x&, y&, _
Rng As Range, Rng0 As Range, Rng1 As Range, arr1, arr()
On Error Resume Next
For SSn = 1 To 16 Step 2
Sn = Range("A" & Sheets(SSn).Cells.Rows.Count).End(xlUp).Row
Set Rng = Sheets(SSn).Range("A1:M" & Sn).Find("65型材").CurrentRegion
Set Rng0 = Rng.Offset(2, 1).Resize(Rng.Offset(2, 1).Rows.Count - 4, Rng.Offset(2, 1).Columns.Count - 2)
arr1 = Rng0.Value
Err.Clear
i = UBound(arr, 2)
ReDim Preserve arr(1 To UBound(arr1, 2), 1 To UBound(arr1, 1) + UBound(arr, 2))
If Err <> 0 Then
    arr = Application.Transpose(arr1)
Else
Do
i = i + 1
x = x + 1
For y = 1 To UBound(arr1, 2)
    arr(y, i) = arr1(x, y)
Next y
Loop Until x = UBound(arr1, 1)
End If
x = 0
Next SSn
Set Rng1 = Sheets("窗型单价汇总表").Range("B65535").End(xlUp).Rows.Offset(1, 0)
Rng1.Resize(UBound(arr, 2), UBound(arr, 1)) = Application.Transpose(arr)

End Sub

跳转到最佳答案楼层

changking123

感觉这种比较少的数据量没有必要，如果非要一个数组一次性填充到工作表的话可以试一下用下面的代码。估计运算速度也不会快多少，懒得试了。
Private Sub CommandButton1_Click()
Dim Sn&, Sn0&, SSn&, i&, x&, y&, _
Rng As Range, Rng0 As Range, Rng1 As Range, arr1, arr()
On Error Resume Next
For SSn = 1 To 16 Step 2
Sn = Range("A" & Sheets(SSn).Cells.Rows.Count).End(xlUp).Row
Set Rng = Sheets(SSn).Range("A1:M" & Sn).Find("65型材").CurrentRegion
Set Rng0 = Rng.Offset(2, 1).Resize(Rng.Offset(2, 1).Rows.Count - 4, Rng.Offset(2, 1).Columns.Count - 2)
arr1 = Rng0.Value
Err.Clear
i = UBound(arr, 2)
ReDim Preserve arr(1 To UBound(arr1, 2), 1 To UBound(arr1, 1) + UBound(arr, 2))
If Err <> 0 Then
    arr = Application.Transpose(arr1)
Else
Do
i = i + 1
x = x + 1
For y = 1 To UBound(arr1, 2)
    arr(y, i) = arr1(x, y)
Next y
Loop Until x = UBound(arr1, 1)
End If
x = 0
Next SSn
Set Rng1 = Sheets("窗型单价汇总表").Range("B65535").End(xlUp).Rows.Offset(1, 0)
Rng1.Resize(UBound(arr, 2), UBound(arr, 1)) = Application.Transpose(arr)

End Sub

DZ稻草人

changking123 发表于 2022-10-18 22:03
感觉这种比较少的数据量没有必要，如果非要一个数组一次性填充到工作表的话可以试一下用下面的代码。估计运 ...

非常感谢哈，慢慢研究起来。