动态复制符合条件的内容

ykcbf1100

这个简单，参与一下。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.4
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 6)
   
5.     End With
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.     For i = 2 To UBound(arr)
   
8.         If InStr(arr(i, 5), "三") Then
   
9.             m = m + 1
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 brr(m, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     With Sheets("Sheet2")
    
16.         .UsedRange.Offset(1) = ""
    
17.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
18.     End With
    
19.     MsgBox "OK！"
    
20. End Sub
    

复制代码