请教老师：多表查找并引用

lygyjt

请教老师：按“查找”按钮，将此表第二行开始（范围在A:Z），每行中，有与sheet2第二行相同的数据，提取出来，放置在从AA2开始的位置（为了说明方便，相同数据单元格已经涂绿色）。

AA列及其右面的区域，放置方式：
1、AA2放置sheet1中O1单元格的数据；AB2放置提取行A列的数据（红色字体）；AC3及它的右面，放置与sheet2第二行相同的数据。
2、再次按“查找”按钮时，所得数据，放在前一次查找结果的下面。
哪写的不清楚，请各位老师留言，我再解释。
具体请见例子： 多表查找并引用.rar (11.21 KB, 下载次数: 11)

2019-5-27 20:34 上传

点击文件名下载附件

hfwufanhf2006

lygyjt 发表于 2019-5-28 21:50
hfwufanhf2006老师您太聪明了，写的相当好！怪我没说清：1、您查找的完全正确，我的例子有失误。2、“再 ...

你的要求很独特，如果你确实不需要清除上次的检索结果，只是在后面累加排列，代码修改如下：
For hs = 2 To 1000
    If IsEmpty(Cells(hs, "aa")) Then
       Exit For
    End If
Next hs
s1 = Sheet1.[o1]
For i = 2 To [b1000].End(3).Row
    s2 = Cells(i, 1)
    js = 29
    bz = False
    For k = 2 To Cells(i, 2).End(2).Column
        s3 = Cells(i, k)
        For j = 2 To Sheet2.[b2].End(2).Column
            If s3 = Sheet2.Cells(2, j) Then
               Cells(hs, "aa") = s1
               Cells(hs, "ab") = s2
               Cells(hs, js) = s3
               js = js + 1
               bz = True
            End If
        Next j
    Next k
    If bz Then
       hs = hs + 1
    End If
Next i


主要的变化只有开的部分，把原来区域清除删掉了，增加起始行数的计算：
For hs = 2 To 1000
    If IsEmpty(Cells(hs, "aa")) Then
       Exit For
    End If
Next hs

通常计算起始行可以直接用[aa1000].end(3).row就能得到，但这个方法有局限，我换了种方法，用循环查找得到起始行。
我还是没想明白，为什么同一个数据源会因为按“查询”次数的多少会得到不同的查询结果，既然你要求我就这么改了。

hfwufanhf2006

代码放在sheet3中：
[aa2:ak100]=""
hs = 2
s1 = Sheet1.[o1]
For i = 2 To [b1000].End(3).Row
    s2 = Cells(i, 1)
    js = 29
    bz = False
    For k = 2 To Cells(i, 2).End(2).Column
        s3 = Cells(i, k)
        For j = 2 To Sheet2.[b2].End(2).Column
            If s3 = Sheet2.Cells(2, j) Then
               Cells(hs, "aa") = s1
               Cells(hs, "ab") = s2
               Cells(hs, js) = s3
               js = js + 1
               bz = True
            End If
        Next j
    Next k
    If bz Then
       hs = hs + 1
    End If
Next i

1、与你展示的结果有一个不同，b5的24也是相同的数字；
2、你说：“再次按“查找”按钮时，所得数据放在前一次查找结果的下面”这句话我也看不懂，我是按照重新检索来做的，也就是说如果数据是一样的，不管按多少次“查询”，结果都相同。代码的第一行就把区域aa2:ak100清空了，就是为了能重复检索；

lygyjt

hfwufanhf2006 发表于 2019-5-28 08:53
代码放在sheet3中：
[aa2:ak100]=""
hs = 2

hfwufanhf2006老师您太聪明了，写的相当好！怪我没说清：1、您查找的完全正确，我的例子有失误。2、“再次按“查找”按钮时，所得数据放在前一次查找结果的下面”这句话我也看不懂。在我给的例子里，按老师写的代码，当第一次按“查找”后，AA2:AA5有数据了。不管A:Z里面的数据是否有变化，第二次按“查找”后，产生的结果就放在AA6开始处。不能按一次清空一次，因为我需要结果的积累。所以，aa:ak的范围不止100行，理论讲是无限多行。
所以，不知还能不能麻烦老师再帮我改下呢？另外，老师请您联系我一下，因为我级别不能给您发消息。Q：577199088  注明精英论坛就行了。

lygyjt

hfwufanhf2006 发表于 2019-5-29 08:54
你的要求很独特，如果你确实不需要清除上次的检索结果，只是在后面累加排列，代码修改如下：
For hs = 2 ...

回老师的话：sheet3中A:Z的数据是变化的，我想把每次变化所查找出来的结果，都统计在一起。这个文件运行程序是这样的：由sheet1中O1的变化，产生不同的sheet3中A:Z的数据。每次产生的数据都不同，所以，查找出来的结果也不同。我想把每次产生的结果放在一起，以便观察它们的规律。出于隐私，我把代码和原始数据都删了，请老师理解和见谅。白天我学习一下老师的程序，哪没弄懂的，再向老师请教。最后还想说：能请老师加下Q（577199088）吗？我想向您表达一下感谢之意。

lygyjt

hfwufanhf2006 发表于 2019-5-27 20:34
你的要求很独特，如果你确实不需要清除上次的检索结果，只是在后面累加排列，代码修改如下：
For hs = 2 ...

老师，上图是我把您的程序，放到我的文件后，第一次按“查找结果”后的数据。

上图是第一次按“查找结果”后，没任何改动，接着第二次按“查找结果”后的数据。肯定是我哪弄错了。因为同样数据，在我上传到论坛的文件中，运行一点问题没有。所以，您写的一点问题没有。想请教下，能否根据上面两个图，帮我判断下哪让我改错了？还是我把具体文件上传到论坛？不知老师能有空吗？
Sub 查找()
Dim hs, s1, i, s2, bz, js, k, s3, j
For hs = 2 To 1000
    If IsEmpty(Cells(hs, "aa")) Then
       Exit For
    End If
Next hs
s1 = Sheet7.[o1]
For i = 2 To [b1000].End(3).Row
    s2 = Cells(i, 1)
    js = 29
    bz = False
    For k = 2 To Cells(i, 2).End(2).Column
        s3 = Cells(i, k)
        For j = 2 To Sheet8.[b2].End(2).Column
            If s3 = Sheet8.Cells(2, j) Then
               Cells(hs, "aa") = s1
               Cells(hs, "ab") = s2
               Cells(hs, js) = s3
               js = js + 1
               bz = True
            End If
        Next j
    Next k
    If bz Then
       hs = hs + 1
    End If
Next i
End Sub

hfwufanhf2006

lygyjt 发表于 2019-5-30 22:37
老师，上图是我把您的程序，放到我的文件后，第一次按“查找结果”后的数据。

上图是第一次按“查找 ...

代码上看不出错误来，如果用你原来的数据，再用你这个代码似乎也是正确的。你应该是把源数据改掉了，或许是数据结构与原来的有不同。我只能看到你把工作表的名称改掉了。
实在不行，你在上传依次数据。

lygyjt

hfwufanhf2006 发表于 2019-5-31 08:58
代码上看不出错误来，如果用你原来的数据，再用你这个代码似乎也是正确的。你应该是把源数据改掉了，或许 ...

又要耽误老师的休息 时间了，真心的说声：谢谢，不好意思啦！ 想请hfwufanhf2006老师指点的文件.rar (273.7 KB, 下载次数: 7)

2019-5-31 20:57 上传

点击文件名下载附件

hfwufanhf2006

lygyjt 发表于 2019-5-31 20:57
又要耽误老师的休息 时间了，真心的说声：谢谢，不好意思啦！

1、主要的问题是你修改了工作表名称，导致找不到对应的参数了，原表参数是sheet1和sheet2，现在叫“初始”和“打勾数据”；
2、另一个不太显眼的问题是起始数据存放的位置从第2行改到了第3行，因为使用了Cells(i, 2).End(2).Column来确定右边界，如果第二行数据为空，那么这个参数的右边界有可能会变成aa列的27。第一次不会出错，因为aa列都是空白，但第二之后aa列就有数据了，这个参数的结果就变成了27。所以我修改这个部分，把Cells(i, 2).End(2).Column改成了：
ls = Cells(i, 2).End(2).Column
ls = IIf(ls > 26, 26, ls)
这里对 ls 的最大值做了限定，不能超过26；
然后就是在运行时关闭了屏幕更新，速度会快很多。下面是完整代码：

Application.ScreenUpdating = False
Dim hs, s1, i, s2, bz, js, k, s3, j
Dim ls
For hs = 2 To 1000
    If IsEmpty(Cells(hs, "aa")) Then
       Exit For
    End If
Next hs
s1 = Worksheets("初始").[o1]
For i = 2 To [b1000].End(3).Row
    s2 = Cells(i, 1)
    js = 29
    bz = False
    ls = Cells(i, 2).End(2).Column
    ls = IIf(ls > 26, 26, ls)
    For k = 2 To ls
        s3 = Cells(i, k)
        For j = 2 To Worksheets("打勾数据").[b2].End(2).Column
            If s3 = Worksheets("打勾数据").Cells(2, j) Then
               Cells(hs, "aa") = s1
               Cells(hs, "ab") = s2
               Cells(hs, js) = s3
               js = js + 1
               bz = True
            End If
        Next j
    Next k
    If bz Then
       hs = hs + 1
    End If
Next i
Application.ScreenUpdating = True

lygyjt

hfwufanhf2006 发表于 2019-5-31 22:21
1、主要的问题是你修改了工作表名称，导致找不到对应的参数了，原表参数是sheet1和sheet2，现在叫“初始 ...

无法用言语表达对老师的敬意！只有小小失落：老师您始终没回答我每次的最后问题。我电话：17604062735，真诚希望老师联系我。