模糊查询 并显示结果

38180203

所有列模糊查询.  说见图片.. 如果能拼音首字母查询更好. 谢谢大佬.....

wang-way

等似水流年大神过来给你写 他擅长

38180203

wang-way 发表于 2024-6-3 18:05
等似水流年大神过来给你写 他擅长

  Option Compare Text

Private Sub CommandButton1_Click() '数组法
  
    Dim arr, f(1 To 9) As Boolean, i&, j&, m&, t
    t = Range("A1").CurrentRegion
    If UBound(t) = 1 Then Exit Sub '7个条件至少选择了1个才查询
    For i = 1 To 9
        If Len(t(2, i)) Then f(i) = True
    Next
    Range("A5:I" & Rows.Count).ClearContents
    arr = Sheets("商品库").Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        If ((f(1) And InStr(arr(i, 1), t(2, 1))) > 0 Or Not f(1)) _
            And ((f(2) And InStr(arr(i, 2), t(2, 2))) > 0 Or Not f(2)) _
            And ((f(3) And InStr(arr(i, 3), t(2, 3))) > 0 Or Not f(3)) _
            And ((f(4) And InStr(arr(i, 4), t(2, 4))) > 0 Or Not f(4)) _
            And ((f(5) And InStr(arr(i, 5), t(2, 5))) > 0 Or Not f(5)) _
            And ((f(6) And InStr(arr(i, 6), t(2, 6))) > 0 Or Not f(6)) _
            And ((f(7) And InStr(arr(i, 7), t(2, 7))) > 0 Or Not f(7)) _
            And ((f(8) And InStr(arr(i, 8), t(2, 8))) > 0 Or Not f(8)) _
            And ((f(9) And InStr(arr(i, 9), t(2, 9))) > 0 Or Not f(9)) Then
            m = m + 1
            For j = 1 To 9
                arr(m, j) = arr(i, j)
            Next
        End If
    Next
    If m Then [a5].Resize(m, 9) = arr
   
    m = 0
    arr = Sheets("商品库2").Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        If ((f(1) And InStr(arr(i, 1), t(2, 1))) > 0 Or Not f(1)) _
            And ((f(2) And InStr(arr(i, 2), t(2, 2))) > 0 Or Not f(2)) _
            And ((f(3) And InStr(arr(i, 3), t(2, 3))) > 0 Or Not f(3)) _
            And ((f(4) And InStr(arr(i, 4), t(2, 4))) > 0 Or Not f(4)) _
            And ((f(5) And InStr(arr(i, 5), t(2, 5))) > 0 Or Not f(5)) _
            And ((f(6) And InStr(arr(i, 6), t(2, 6))) > 0 Or Not f(6)) _
            And ((f(7) And InStr(arr(i, 7), t(2, 7))) > 0 Or Not f(7)) _
            And ((f(8) And InStr(arr(i, 8), t(2, 8))) > 0 Or Not f(8)) _
            And ((f(9) And InStr(arr(i, 9), t(2, 9))) > 0 Or Not f(9)) Then
            m = m + 1
            For j = 1 To 9
                arr(m, j) = arr(i, j)
            Next
        End If
    Next
'If m Then Cells(Rows.Count, 1).End(3).Offset(1).Resize(m, 9) = arr
  If m Then Cells(Rows.Count, 1).End(3).Offset(1).Resize(m, 9) = arr

  If m Then Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(m, 9) = arr
End Sub


用这个能不能修改?

ykcbf1100

你这查询表设计的，二个表还得查二次。

38180203

ykcbf1100 发表于 2024-6-3 18:38
你这查询表设计的，二个表还得查二次。

老师, 也可以

wang-way

1. function query1(){
   
2.         let ar=ThisWorkbook.Worksheets.Item('数据库1').Range('A2').CurrentRegion.Value();
   
3.         let sht=ThisWorkbook.Worksheets.Item('查询');
   
4.         Application.Intersect(sht.UsedRange.Offset(5),sht.Range('A:K')).Clear();
   
5.         let fs=sht.Range("A2").Resize(1,ar[0].length).Value()[0];
   
6.         let cnt=fs.filter(f=>f!=null).length;
   
7.         console.log(cnt);
   
8.         let br=ar.slice(1).filter(r=>{
   
9.                 let n=0;
   
10.                 fs.forEach((f,i)=>{
    
11.                         if(i==0){
    
12.                                 if(WorksheetFunction.Text(r[0],'m')==f)  n=n+1
    
13.                         }
    
14.                         else{
    
15.                                 if(f!=null && String(r[i]).toLowerCase().includes(f.toLowerCase())) n=n+1
    
16.                         }
    
17.                 });
    
18.                 if(n==cnt) return true;
    
19.         })
    
20.         //console.log(br.length);
    
21.         sht.Range('A5').Resize(br.length,br[0].length).Value2=br;
    
22. }
    

复制代码

wang-way

再精简一下

wang-way

38180203 发表于 2024-6-3 18:19
Option Compare Text

Private Sub CommandButton1_Click() '数组法

判断代码太长了#####

38180203

wang-way 发表于 2024-6-3 19:49
判断代码太长了#####

能实现功能就好了,老师

38180203

wang-way 发表于 2024-6-3 19:10

老师,输入发货数量查询时出现这样的.