[已解决]求编一段VB代码，实现查询后显示后面相关的东西

tzjx200521 · 发表于 2012-3-11 08:52

求编一段VB代码，要求如附件，有第一个表按查询，有查询后面单元格输入一些查询的东西，，能在标黄色区域显示查询出的所有相关的东西。能实现吗/ 求老师解答下。

最佳答案

月排行榜 / 总排行榜

bb75308973

2012-3-11 11:30

本帖最后由 bb75308973 于 2012-3-11 12:43 编辑

好吧,给你弄了下,你测试看看

在A1 输入要搜索的内容,然后点查询

Sub 查询()
Dim a, i As Integer, n As Integer, iadd$, n1 As Integer
Dim sh As Worksheet, rg As Range, rg1 As Range, rgx As Range, rgy As Range
Dim sc As Worksheet
Dim arr
Set sc = Sheets(1)
n1 = 2
a = sc.Range("A1").Value
Application.ScreenUpdating = False
On Error Resume Next
sc.Range("A2:D65536").Clear
For n = 2 To Sheets.Count
Set sh = Sheets(n)
With sh
Set rg1 = .Cells.Find(a, , , xlPart)
If Not rg1 Is Nothing Then
iadd = rg1.Address
Do
i = i + 1
Set rgx = rg1.CurrentRegion
Set rgy = .Columns(rg1.Column)
Set rg2 = Application.Intersect(rgx, rgy)
arr = rg2
sc.Range("A" & n1).Resize(, 4) = WorksheetFunction.Transpose(arr)
n1 = n1 + 1
Set rg1 = .Cells.FindNext(rg1)
If rg1 Is Nothing Then Exit Do
Loop Until iadd = rg1.Address
End If
End With
Next
On Error GoTo 0
sc.Range("A:D").RemoveDuplicates (Array(1, 2, 3, 4))
sc.Cells.Font.Size = 10
Application.ScreenUpdating = True
End Sub

复制代码

跳转到最佳答案楼层

zjdh · 发表于 2012-3-11 09:12

没见过你这样的数据结构，晕！

yzwzxy · 发表于 2012-3-11 09:16

咱也没有见过，不知道哪位高手解决下

tzjx200521 · 发表于 2012-3-11 09:32

其它结构呢。。比如在第一表查出后面表的东西。。相当于查找工作簿显示在第一个特定区域能用VB做吗？

bb75308973 · 发表于 2012-3-11 09:38

这个应该能实现吧
说说我的想法供参考,没时间写代码了
查找每一个表的每一个单元格的内容,用部分匹配来搜,搜到后计算他的行号,然后取他附近一3个数据(当然这3个数据是有规律的)一起放进一个二维数组
同时二维数组的行维要+1
然后查找下一个
找完后
将二维数据输出到第一个表的黄色区域

tzjx200521 · 发表于 2012-3-11 09:48

代码来个啊。。求代码

bb75308973 · 发表于 2012-3-11 11:30

这个最佳答案由 bb75308973 给出，感谢 bb75308973 的回答。

单击隐藏图章

本帖最后由 bb75308973 于 2012-3-11 12:43 编辑

好吧,给你弄了下,你测试看看

在A1 输入要搜索的内容,然后点查询

Sub 查询()
Dim a, i As Integer, n As Integer, iadd$, n1 As Integer
Dim sh As Worksheet, rg As Range, rg1 As Range, rgx As Range, rgy As Range
Dim sc As Worksheet
Dim arr
Set sc = Sheets(1)
n1 = 2
a = sc.Range("A1").Value
Application.ScreenUpdating = False
On Error Resume Next
sc.Range("A2:D65536").Clear
For n = 2 To Sheets.Count
Set sh = Sheets(n)
With sh
Set rg1 = .Cells.Find(a, , , xlPart)
If Not rg1 Is Nothing Then
iadd = rg1.Address
Do
i = i + 1
Set rgx = rg1.CurrentRegion
Set rgy = .Columns(rg1.Column)
Set rg2 = Application.Intersect(rgx, rgy)
arr = rg2
sc.Range("A" & n1).Resize(, 4) = WorksheetFunction.Transpose(arr)
n1 = n1 + 1
Set rg1 = .Cells.FindNext(rg1)
If rg1 Is Nothing Then Exit Do
Loop Until iadd = rg1.Address
End If
End With
Next
On Error GoTo 0
sc.Range("A:D").RemoveDuplicates (Array(1, 2, 3, 4))
sc.Cells.Font.Size = 10
Application.ScreenUpdating = True
End Sub

复制代码

bb75308973 · 发表于 2012-3-11 23:20

本帖最后由 bb75308973 于 2012-3-11 23:24 编辑

tzjx200521 发表于 2012-3-11 21:58
见截图。。点结束查是能查出来，

明白了,你用的是2003版本的,建议升级到2007以上版本,好用多了!
2003没有去重功能
因为同一组结果里面的内容可能会含有搜索词的内容,这样就会出现重复输出结果
2007版本以上这个是很容易解决的,一个代码就OK了
菜单里也有去重功能
你可以在论坛上搜下2003的去重代码,将那条代码修改下就好了!

当然如果你不想去重你可以将
On Error GoTo 0
这句移动End sub 前面那里去

tzjx200521 · 发表于 2012-3-11 21:58

见截图。。点结束查是能查出来，

tzjx200521 · 发表于 2012-3-11 21:51

33.sc.Range("A:D").RemoveDuplicates (Array(1, 2, 3, 4))

这行提示有误。。。

		自动登录	找回密码
密码			注册

[已解决]求编一段VB代码，实现查询后显示后面相关的东西

相关帖子