任意多条件及关键字查询

758586

各位大师好！

有事相求,现有一单号查询功能用起来不太方便，找了很多实在搞不定,想请各位师傅帮忙修改，或者重新帮忙写一个,先谢谢各位

大止意思是 任 一 多条件及关键字查询

1.在订单工作表颜色标记单元格，任一个单元格 否着多个 选择条件后能查询数据库的内容。
2.另在c15单元格 对应数据库表 i 列名称规格 关键字查询,
任意多条件及关键字查询.rar (59.99 KB, 下载次数: 18)

2024-3-31 13:17 上传

点击文件名下载附件

3190496160

Sub 不定条件个数查询()
With Sheets("数据库")
    R = .Cells(Rows.Count, 1).End(xlUp).Row
    If R < 2 Then MsgBox "数据库为空！": End
    ar = .Range("a1:w" & R)
End With
With Sheets("订单")
    gg = .[c15]
    bm = .[c16]
    dh = .[e15]
    gys = .[g15]
    fl = .[g16]
    rq = .[h16]
    rr = Array(gg, 9, bm, 16, dh, 6, gys, 7, fl, 8, rq, 13)
    Dim arr()
    ReDim arr(1 To 7, 1 To 2)
    For i = 0 To UBound(rr) Step 2
        If rr(i) <> "" Then
            n = n + 1
            arr(n, 1) = rr(i)
            arr(n, 2) = rr(i + 1)
        End If
    Next i
    If n = "" Then MsgBox "请至少输入一个查询条件！": End
    Dim brr()
    ReDim brr(1 To UBound(ar), 1 To 7)
    For i = 2 To UBound(ar)
        k = 0
        For s = 1 To n
            lh = arr(s, 2)
            zd = arr(s, 1)
            If ar(i, lh) = zd Then
                k = k + 1
            End If
        Next s
        If k = n Then
            m = m + 1
            brr(m, 1) = m
            For j = 9 To 14
                brr(m, j - 7) = ar(i, j)
            Next j
        End If
    Next i
    If m = "" Then MsgBox "没有符合条件的数据！": End
    .UsedRange.Offset(17) = Empty
    .[b18].Resize(m, UBound(brr, 2)) = brr
End With
MsgBox "ok!"
End Sub

3190496160

任意多条件及关键字查询.rar (59.51 KB, 下载次数: 22)

2024-3-31 14:01 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.31
   
2.     Dim arr, brr
   
3.     c = 6
   
4.     ReDim a(1 To c), b(1 To c), ft(1 To c)
   
5.     With Sheets("订单")
   
6.         a(1) = .[c15]: b(1) = 9
   
7.         a(2) = .[e15]: b(2) = 6
   
8.         a(3) = .[g15]: b(3) = 7
   
9.         a(4) = .[c16]: b(4) = 2
   
10.         a(5) = .[g16]: b(5) = 7
    
11.         a(6) = .[h16]: b(6) = 15
    
12.     End With
    
13.     bb = [{1,9,10,11,12,13,14}]
    
14.     With Sheets("数据库")
    
15.         R = .Cells(Rows.Count, 1).End(3).Row
    
16.         arr = .Range("a2:o" & R)
    
17.     End With
    
18.     ReDim brr(1 To UBound(arr), 1 To 7)
    
19.     For i = 1 To UBound(arr)
    
20.         fft = 1
    
21.         For x = 1 To c
    
22.             ft(x) = IIf(a(x) = Empty Or arr(i, b(x)) Like "*" & a(x) & "*", 1, 0)
    
23.             fft = fft * ft(x)
    
24.         Next
    
25.         If fft = 1 Then
    
26.             m = m + 1
    
27.             brr(m, 1) = m
    
28.             For j = 2 To UBound(bb)
    
29.                 brr(m, j) = arr(i, bb(j))
    
30.             Next
    
31.         End If
    
32.     Next
    
33.     If m > 0 Then
    
34.         With Sheets("订单")
    
35.             .[b18:h10000].ClearContents
    
36.             .[b18].Resize(m, 7) = brr
    
37.         End With
    
38.     End If
    
39.     MsgBox "OK！"
    
40. End Sub
    
41. 
    

复制代码

758586

感谢上两位师傅，都是多次帮我 真心感谢 感谢 ！
两位师傅辛苦了,一步达到要求 。谢谢了
现在用起来方便多了,在高手面前一切简单

758586

ykcbf1100 发表于 2024-3-31 14:22
附件供参考。。。

师傅我有个没有想到的问题，还得麻烦你
查询出来的内容不需要重新排序号，需要查询出来的序号不变，修改的保存需要原本的序列号 才行，
师傅帮忙看看需要怎么修改,谢谢

ykcbf1100

758586 发表于 2024-3-31 15:11
师傅我有个没有想到的问题，还得麻烦你
查询出来的内容不需要重新排序号，需要查询出来的序号不变，修改 ...

改好了。。。

758586

ykcbf1100 发表于 2024-3-31 15:15
改好了。。。

ykcbf1100师傅，太感谢了 ！帮我解决了不少问题,谢谢

ykcbf1100

758586 发表于 2024-3-31 15:30
ykcbf1100师傅，太感谢了 ！帮我解决了不少问题,谢谢

满意就好。。。