求助提取符合条件数据VBA

三票

求助提取符合条件数据VBA

鄂龙蒙

表中公式太多吧？难打开呀！！！

三票

鄂龙蒙 发表于 2022-11-21 11:13
表中公式太多吧？难打开呀！！！

附件已修改

liulang0808

Sub 按钮286_Click()
    r = Cells(Rows.Count, "x").End(3).Row
    arr = [q1].Resize(r, 13)
    brr = Range("am3:an9")
    r = 0
    For j = 2 To UBound(arr)
        For i = 1 To 6
            If arr(j, i + 7) < brr(i, 1) Or arr(j, i + 7) > brr(i, 2) Then
                GoTo l1
            End If
        Next i
        r = r + 1
        For i = 1 To UBound(arr, 2)
            arr(r, i) = arr(j, i)
        Next i
l1:
    Next j
    If r > 0 Then [bi1].Resize(r, UBound(arr, 2)) = arr
End Sub

liulang0808

附件内容供参考。。。。。。。

三票

liulang0808 发表于 2022-11-21 13:18
附件内容供参考。。。。。。。

老师如果某个条件为空则默认这个条件全符合。做下修改

liulang0808

Sub 按钮286_Click()
    r = Cells(Rows.Count, "x").End(3).Row
    arr = [q1].Resize(r, 13)
    brr = Range("am3:an9")
    r = 0
    For j = 2 To UBound(arr)
        For i = 1 To 6
            If Len(brr(i, 1)) > 0 And Len(brr(i, 2)) > 0 Then
                If arr(j, i + 7) < brr(i, 1) Or arr(j, i + 7) > brr(i, 2) Then
                    GoTo l1
                End If
            End If
        Next i
        r = r + 1
        For i = 1 To UBound(arr, 2)
            arr(r, i) = arr(j, i)
        Next i
l1:
    Next j
    If r > 0 Then [bi1].Resize(r, UBound(arr, 2)) = arr
End Sub

liulang0808

供参考。。。。。。。。。。。。