符合条件的复制

yuhaowang

请大侠们出手相助。谢谢
如图

Book1.rar (35.85 KB, 下载次数: 9)

2019-6-25 17:13 上传

点击文件名下载附件

Private Sub CommandButton1_Click()
Dim arr, brr, crr(), drr(), r1&, r2&, r3&, r4&, i&, j&, d, h, m, t$, tt, gz, t1, sl, sl1, sl2               '声明

。
。
。
。
。
。

   Range("m27").Resize(r4, UBound(drr, 2)) = drr                       '把工作表中的m27单元格扩充为r行第二维上界arr列大小的区域=动态数组drr赋值
Erase drr                                                                                '操作好后释放数组内存

End Sub

lovelfg

Sub test()
Dim i As Integer
Dim j As Integer
j = 27
For i = 27 To Range("J65536").End(xlUp).Row
    If Range("J" & i) = "NoTrade" Then
        Range("A" & i).Resize(1, 11).Copy Range("M" & j)
        j = j + 1
    End If
Next
End Sub

新增了一段代码

astupig

1. Sub MoveNoTrade()
   
2.     Dim maxRow As Long, arr, cnt As Long, brr(), i As Long
   
3.     maxRow = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Range("A1:K" & maxRow)
   
5.     For i = 27 To maxRow
   
6.         If arr(i, 10) = "NoTrade" Then
   
7.             cnt = cnt + 1
   
8.             ReDim Preserve brr(1 To cnt)
   
9.             brr(cnt) = WorksheetFunction.Index(arr, i, 0)
   
10.             Range("M" & 26 + cnt).Resize(1, UBound(brr(cnt))) = brr(cnt)
    
11.         End If
    
12.     Next i
    
13. End Sub

复制代码

gdfcx

1. Sub macro()
   
2.     Dim arr, brr(), i%, j%, k%
   
3.     arr = [a27].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     For i = 1 To UBound(arr)
   
6.         If arr(i, 10) = "NoTrade" Then
   
7.             k = k + 1
   
8.             For j = 1 To UBound(arr, 2)
   
9.                 brr(k, j) = arr(i, j)
   
10.             Next j
    
11.         End If
    
12.     Next i
    
13.     [m27].Resize(k, j - 1) = brr
    
14. End Sub
    

复制代码

yuhaowang

谢谢各位指教。
3个方案的运行速度分别是：
0.0078125
0
0