任意多条件及关键字查询

758586 · 发表于 2024-3-31 13:18

各位大师好！

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

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

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

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

3190496160 · 发表于 2024-3-31 14:01

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 · 发表于 2024-3-31 14:02

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

ykcbf1100 · 发表于 2024-3-31 14:22

本帖最后由 ykcbf1100 于 2024-3-31 15:33 编辑

附件供参考。。。

ykcbf1100 · 发表于 2024-3-31 14:23

参与一下。。。

Sub ykcbf() '//2024.3.31
Dim arr, brr
c = 6
ReDim a(1 To c), b(1 To c), ft(1 To c)
With Sheets("订单")
a(1) = .[c15]: b(1) = 9
a(2) = .[e15]: b(2) = 6
a(3) = .[g15]: b(3) = 7
a(4) = .[c16]: b(4) = 2
a(5) = .[g16]: b(5) = 7
a(6) = .[h16]: b(6) = 15
End With
bb = [{1,9,10,11,12,13,14}]
With Sheets("数据库")
R = .Cells(Rows.Count, 1).End(3).Row
arr = .Range("a2:o" & R)
End With
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 1 To UBound(arr)
fft = 1
For x = 1 To c
ft(x) = IIf(a(x) = Empty Or arr(i, b(x)) Like "*" & a(x) & "*", 1, 0)
fft = fft * ft(x)
Next
If fft = 1 Then
m = m + 1
brr(m, 1) = m
For j = 2 To UBound(bb)
brr(m, j) = arr(i, bb(j))
Next
End If
Next
If m > 0 Then
With Sheets("订单")
.[b18:h10000].ClearContents
.[b18].Resize(m, 7) = brr
End With
End If
MsgBox "OK！"
End Sub

复制代码

758586 · 发表于 2024-3-31 14:46

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

758586 · 发表于 2024-3-31 15:11

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

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

ykcbf1100 · 发表于 2024-3-31 15:15

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

改好了。。。

758586 · 发表于 2024-3-31 15:30

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

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

ykcbf1100 · 发表于 2024-3-31 15:32

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

满意就好。。。

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

[已解决] 任意多条件及关键字查询

评分

评分

评分