动态复制符合条件的内容

ty1399

如何动态复制，某列中符合条件内容？

内容常有增减，数据量大，排序后手工复制很繁琐。。。

shiruiqiang

你这样直接筛选就行了。或者sql

yanglinzi

1. Sub 复制()
   
2. Dim arr, brr, i, j
   
3. r = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
   
4. arr = Sheet1.Range("a1:f" & r)
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. n = 1
   
7. For i = 2 To UBound(arr)
   
8.     If InStr(arr(i, 5), "三") Then
   
9.         n = n + 1
   
10.         For j = 1 To 6
    
11.             brr(1, j) = arr(1, j)
    
12.             brr(n, j) = arr(i, j)
    
13.         Next
    
14.     End If
    
15. Next
    
16. [k1].Resize(n, 6) = brr
    
17. End Sub
    

复制代码

yanglinzi

请测试。。

baofa2

1. Sub test0()
   
2.   
   
3.   Dim ran As Range, s As String
   
4.   Dim ar, i As Long, j As Long
   
5.   s = InputBox("请输入", "输入提示：", "三"): If s = "" Then Exit Sub
   
6.   
   
7.   With Range("A1").CurrentRegion
   
8.     j = .Columns.Count
   
9.     ar = .Columns(5)
   
10.     Set ran = .Rows(1)
    
11.   End With
    
12.   For i = 2 To UBound(ar)
    
13.     If ar(i, 1) = s Then
    
14.       Set ran = Union(ran, Range("A" & i).Resize(, j))
    
15.     End If
    
16.   Next
    
17.   ran.Copy
    
18.   
    
19. End Sub
    

复制代码

swl4561255

1. Private Sub CommandButton1_Click()
   
2. Dim myr As Range
   
3. Set myr = Range(Cells(1, 1), Cells(1, 6))
   
4. arr = Range("A1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     If arr(i, 5) = "三" Then
   
7.         Set myr = Union(myr, Range(Cells(i, 1), Cells(i, 6)))
   
8.     End If
   
9. Next
   
10. myr.Copy [H1]
    
11. End Sub

复制代码

ty1399

baofa2 发表于 2024-5-4 12:29

感谢大神回复，如果筛选结果不带标题行，且只复制1-5列，代码改如何修改呢？

baofa2

ty1399 发表于 2024-5-4 15:26
感谢大神回复，如果筛选结果不带标题行，且只复制1-5列，代码改如何修改呢？

1. Sub test0()
   
2.   Dim ran As Range, s As String
   
3.   Dim ar, i As Long, j As Long
   
4.   s = InputBox("请输入", "输入提示：", "三"): If s = "" Then Exit Sub
   
5.   ar = Range("A1").CurrentRegion.Columns(5).Value
   
6.   For i = 2 To UBound(ar)
   
7.     If ar(i, 1) = s Then
   
8.       If Not ran Is Nothing Then Set ran = Union(ran, Range("A" & i).Resize(, 5)) Else Set ran = Range("A" & i).Resize(, 5)
   
9.     End If
   
10.   Next
    
11.   If Not ran Is Nothing Then ran.Copy Else MsgBox "木有!"
    
12. End Sub
    

复制代码

ty1399

baofa2 发表于 2024-5-4 15:34

太厉害了，完美实现！通过推演学习了好多知识，谢谢！尤其那个“木有”，就很细节

a18b88

swl4561255 发表于 2024-5-4 14:21

好强大，学习了。