[已解决]数据检索与填充

wangyuhang6

自动检索填充.rar (7.3 KB, 下载次数: 16)

2012-3-18 14:42 上传

点击文件名下载附件
表格说明 说明：A列为原始数据，可能上万条，B列是搜索条件，我想在B列输入搜索条件后，系统自动在A列中查找尾数与B列相同的数据，填充到C列，其他包含该字段的数据填充到D列

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-3-18 15:45

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim ar, st, br(), cr()
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     If Target.Address <> "$B$2" Then Exit Sub
   
5.     Range("c2:c65536").ClearContents
   
6.     Range("d2:d65536").ClearContents
   
7.     st = Range("b2")
   
8.     ar = Range("a2:a" & Range("a65536").End(xlUp).Row)
   
9.     ReDim br(1 To UBound(ar))
   
10.     ReDim cr(1 To UBound(ar))
    
11.     For i = 1 To UBound(ar)
    
12.         If ar(i, 1) Like "*" & st Then
    
13.             j = j + 1
    
14.             br(j) = ar(i, 1)
    
15.         ElseIf ar(i, 1) Like "*" & st & "*" And Not ar(i, 1) Like "*" & st Then
    
16.             k = k + 1
    
17.             cr(k) = ar(i, 1)
    
18.         End If
    
19.     Next
    
20.     If j > 0 Then Range("c2").Resize(j, 1) = Application.Transpose(br)
    
21.     If k > 0 Then Range("d2").Resize(k, 1) = Application.Transpose(cr)
    
22. End Sub

复制代码

放在工作表事件里
自动检索填充.rar (15.69 KB, 下载次数: 9)

2012-3-18 15:45 上传

点击文件名下载附件

跳转到最佳答案楼层

hubinhb

数组公式或者VBA都行

wangyuhang6

请问能具体一些吗,谢谢！

lisachen

1. Sub search()
   
2. Dim arr, brr
   
3. Dim i As Long
   
4. arr = Range("a1:a" & Range("a65536").End(3).Row)
   
5. ReDim brr(1 To UBound(arr), 1 To 2)
   
6. 
   
7. For i = 1 To UBound(arr)
   
8. If arr(i, 1) Like "*" & Cells(2, 2) Then
   
9. k = k + 1
   
10. brr(k, 1) = arr(i, 1)
    
11. ElseIf arr(i, 1) Like "*" & Cells(2, 2) & "*" Then
    
12. m = m + 1
    
13. brr(m, 2) = arr(i, 1)
    
14. End If
    
15. Next i
    
16. Range("c2:d65536").ClearContents
    
17. Range("c2").Resize(UBound(arr), 2) = brr
    
18. End Sub
    

复制代码

自动检索填充.rar (16.68 KB, 下载次数: 3)

2012-3-18 15:44 上传

点击文件名下载附件

hrpotter

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim ar, st, br(), cr()
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     If Target.Address <> "$B$2" Then Exit Sub
   
5.     Range("c2:c65536").ClearContents
   
6.     Range("d2:d65536").ClearContents
   
7.     st = Range("b2")
   
8.     ar = Range("a2:a" & Range("a65536").End(xlUp).Row)
   
9.     ReDim br(1 To UBound(ar))
   
10.     ReDim cr(1 To UBound(ar))
    
11.     For i = 1 To UBound(ar)
    
12.         If ar(i, 1) Like "*" & st Then
    
13.             j = j + 1
    
14.             br(j) = ar(i, 1)
    
15.         ElseIf ar(i, 1) Like "*" & st & "*" And Not ar(i, 1) Like "*" & st Then
    
16.             k = k + 1
    
17.             cr(k) = ar(i, 1)
    
18.         End If
    
19.     Next
    
20.     If j > 0 Then Range("c2").Resize(j, 1) = Application.Transpose(br)
    
21.     If k > 0 Then Range("d2").Resize(k, 1) = Application.Transpose(cr)
    
22. End Sub

复制代码

放在工作表事件里
自动检索填充.rar (15.69 KB, 下载次数: 9)

2012-3-18 15:45 上传

点击文件名下载附件

wangyuhang6

hrpotter 发表于 2012-3-18 15:45
放在工作表事件里

首先感谢楼上两位老师的指点，我是新手，不知道“工作事件”在哪，能否演示一下效果呢，我用的版本是2007 ，多谢！

hrpotter

wangyuhang6 发表于 2012-3-18 17:48
首先感谢楼上两位老师的指点，我是新手，不知道“工作事件”在哪，能否演示一下效果呢，我用的版本是2007 ...

在vbe里，alt+f11打开，双击左边工程窗口的sheet1,看我的附件吧，已经做好了!在单元格里输入查询内容按回车，C,D列的数据会自动查询出来