VBA如何同时实现多件查找

eachy

下面的描术以工作表“筛选”为当前工作表。
A        说明：工作表“筛选”的C2的值为201902413和C3的值为500的意思是说在工作表“基本量”里查找的范围就是从201902413往上倒数加499行。总共500行含201902413本身               
                       
B         查找的条件是同时满足下面五个条件：假设查看下工作表“基本量”的C816:G816是否答合条件               
                第一，这里的E2的数值-G2的数值<=工作表“基本量”CELLS.(816,C).VALUE<=这里的E2的数值+G2的数值       
                第二，这里的E3的数值-G3的数值<=工作表“基本量”CELLS.(816,D).VALUE<=这里的E3的数值+G3的数值       
                第三，这里的E4的数值-G4的数值<=工作表“基本量”CELLS.(816,E).VALUE<=这里的E4的数值+G4的数值       
                第四，工作表“基本量”CELLS.(816,F).value=这里的E5的数值       
                第五，工作表“基本量”CELLS.(816,G).value=这里的E6的数值       
C        假设工作表“基本量”的C816:G816同时符合以上的五个条时，就把工作表“基本量”.cells(816,A).value=201902413复制到这里的I2               
        如果不符合，则继续往C815:G815查找，一直到上面说到的从C2这个数值所在的行往上倒数总共有C3这个数值的行       
   也就是说查找条件是在工作表“基本量”的C:G这个区域（符合工作表“筛选”C2和C3的行数规定），而要的数据是在工作表“基本量”的A列。       
D        如果在工作表“基本量”找到同时符合条件的A列数值超过100个，只需留下从C2这个值所在行开始倒数最近的100个即可，并复制到I2:I101这里       
        注意找数据时是从下往上找，找到了却是从上往下的顺序放到I2:I101里比如说找到第一个201902413放I2，找到第二个是201902405，就放到I3.如此类推。       

最后把这个程序写在“按钮1” 可以实现一键完成
菜鸟学做VBA，不知这样的表达是否清楚，还请各位大咖 高手帮忙 ，
万分感谢 ！！！
不知道为什么不能上传EXCEL表
       

eachy

大师指点下吧，

xjl565135022

试下看这个，结果只出来一个数据，不知道符不符全要求

eachy

4楼，xjl565135022 太帅了，这就是我想要的，太谢谢您了

eachy

xjl565135022 发表于 2019-5-25 20:51
试下看这个，结果只出来一个数据，不知道符不符全要求

4楼，xjl565135022 太帅了，这就是我想要的，太谢谢您了

eachy

为了让有碰到同样问题的朋友能学习，我把4楼帮我写的程序发出来。
Sub test()
Dim crr()
Set sht = Sheets("基本量")
Set sht1 = Sheets("筛选")
a = sht.[A65536].End(3).Row
arr = sht.Range("A1:G" & a)
brr = sht1.Range("A1:G6")
'获取 计算序数所在行
For i = 3 To a
    If arr(i, 1) = brr(2, 3) Then
        c = i
        Exit For
    End If
Next
If c >= brr(3, 3) Then
    For i = c To c - brr(3, 3) + 1 Step -1
        If arr(i, 3) >= brr(2, 5) - brr(2, 7) And arr(i, 3) <= brr(2, 5) + brr(2, 7) Then '条件1
            If arr(i, 4) >= brr(3, 5) - brr(3, 7) And arr(i, 4) <= brr(3, 5) + brr(3, 7) Then '条件2
                If arr(i, 5) >= brr(4, 5) - brr(4, 7) And arr(i, 5) <= brr(4, 5) + brr(4, 7) Then '条件3
                    If arr(i, 6) = brr(5, 5) Then '条件4
                        If arr(i, 7) = brr(6, 5) Then '条件5
                            If d < 99 Then
                                d = d + 1
                                ReDim Preserve crr(0, d - 1)
                                crr(0, d - 1) = arr(i, 1)
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next
    sht1.Range("I2").Resize(UBound(crr, 2) + 1, 1) = Application.Transpose(crr)
Else
    xx = MsgBox(brr(2, 3) & "前面的行数少于" & brr(3, 3) & "行", , "一个很温馨的提示！")
End If
End Sub