提取相符合的数据

yueyiggjjddmm

在K1输入姓名后，将C2:G 区符合K1的值后 将结果提取到P2:T区域


jl.rar (10.46 KB, 下载次数: 6)

2023-3-17 21:41 上传

点击文件名下载附件

liulang0808

Sub 按钮1_Click()
    arr = [c2].CurrentRegion
    r = 0
    For j = 1 To UBound(arr)
        If arr(j, 1) = [k1] Then
            r = r + 1
            For i = 1 To UBound(arr, 2)
                arr(r, i) = arr(j, i)
            Next i
        End If
    Next j
    [p2].CurrentRegion.ClearContents
    If r > 0 Then [p2].Resize(r, UBound(arr, 2)) = arr
End Sub

liulang0808

附件内容供参考。。。。

lushang2018

1. Sub 测试()  ''答题专用套路--by:学习使我快乐
   
2.     Dim i, j, k, m, n, arr, brr, crr, drr
   
3.     Dim dic As Object, key As String, keys, items
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     Sheet1.Activate
   
6.     arr = Range("C2").CurrentRegion
   
7.     For i = LBound(arr) To UBound(arr)
   
8.         key = arr(i, 1)
   
9.         dic(key) = dic(key) & "," & i
   
10.     Next
    
11.     keys = dic.keys
    
12.     items = dic.items
    
13.     For i = LBound(keys) To UBound(keys)
    
14.         key = keys(i)
    
15.         If key = [K1] Then
    
16.             brr = Split(items(i), ",")
    
17.             ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
    
18.             For j = 1 To UBound(brr)
    
19.                 For k = 1 To UBound(arr, 2)
    
20.                     crr(j, k) = arr(brr(j), k)
    
21.                 Next
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     [P2].Resize(UBound(brr), UBound(arr, 2)) = crr
    
26. End Sub

复制代码

lushang2018

试一试，看看行不行