[已解决]在模糊查找的基础上增加精确查找功能

mengliang3000

表格已经做了模糊查找功能，但是有重合数据时无法正确统计数量，希望再勾选复选框后实现精确查找的功能。

多条件精确查找。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-2-28 08:36

1. Private Sub CommandButton1_Click()    '数组法
   
2.     Dim arr, brr(), f(1 To 17) As Boolean, t, i&, j&, m&, lr&, lc&
   
3.     t = Range("A2:S2")
   
4.     For i = 1 To 17 Step 1
   
5.         If Len(t(1, i)) Then f(i) = True
   
6.     Next
   
7.     If Not (f(1) Or f(3) Or f(5)) Then Exit Sub
   
8.     With Sheets("出入库汇总表")
   
9.         arr = .Range("A2").CurrentRegion
   
10.         lr = .Range("b" & Rows.Count).End(xlUp).Row
    
11.         lc = UBound(arr, 2)
    
12.         ReDim brr(1 To lr, 1 To lc)    '重新定义的数组
    
13.         If Me.CheckBox1.Value Then
    
14.             For i = 2 To lr
    
15.                 If ((f(1) And (arr(i, 2) = t(1, 1))) Or Not f(1)) _
    
16.                    And ((f(3) And (arr(i, 4) = t(1, 3))) Or Not f(3)) _
    
17.                    And ((f(5) And (arr(i, 17) = t(1, 5))) Or Not f(5)) Then
    
18.                     m = m + 1
    
19.                     For j = 1 To lc
    
20.                         brr(m, j) = arr(i, j)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24.         Else
    
25.             For i = 2 To lr
    
26.                 If ((f(1) And InStr(arr(i, 2), t(1, 1)) > 0) Or Not f(1)) _
    
27.                    And ((f(3) And InStr(arr(i, 4), t(1, 3)) > 0) Or Not f(3)) _
    
28.                    And ((f(5) And InStr(arr(i, 17), t(1, 5)) > 0) Or Not f(5)) Then
    
29.                     m = m + 1
    
30.                     For j = 1 To lc
    
31.                         brr(m, j) = arr(i, j)
    
32.                     Next
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.     End With
    
37.     Range("A5:S" & Rows.Count).ClearContents
    
38.     If m Then [a5].Resize(m, j - 1) = brr
    
39. End Sub

复制代码

跳转到最佳答案楼层

zjdh

稍作改动：
出入库汇总表 - 副本.rar (40.83 KB, 下载次数: 12)

2014-2-28 08:36 上传

点击文件名下载附件

hwc2ycy

1. Private Sub CommandButton1_Click()    '数组法
   
2.     Dim arr, brr(), f(1 To 17) As Boolean, t, i&, j&, m&, lr&, lc&
   
3.     t = Range("A2:S2")
   
4.     For i = 1 To 17 Step 1
   
5.         If Len(t(1, i)) Then f(i) = True
   
6.     Next
   
7.     If Not (f(1) Or f(3) Or f(5)) Then Exit Sub
   
8.     With Sheets("出入库汇总表")
   
9.         arr = .Range("A2").CurrentRegion
   
10.         lr = .Range("b" & Rows.Count).End(xlUp).Row
    
11.         lc = UBound(arr, 2)
    
12.         ReDim brr(1 To lr, 1 To lc)    '重新定义的数组
    
13.         If Me.CheckBox1.Value Then
    
14.             For i = 2 To lr
    
15.                 If ((f(1) And (arr(i, 2) = t(1, 1))) Or Not f(1)) _
    
16.                    And ((f(3) And (arr(i, 4) = t(1, 3))) Or Not f(3)) _
    
17.                    And ((f(5) And (arr(i, 17) = t(1, 5))) Or Not f(5)) Then
    
18.                     m = m + 1
    
19.                     For j = 1 To lc
    
20.                         brr(m, j) = arr(i, j)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24.         Else
    
25.             For i = 2 To lr
    
26.                 If ((f(1) And InStr(arr(i, 2), t(1, 1)) > 0) Or Not f(1)) _
    
27.                    And ((f(3) And InStr(arr(i, 4), t(1, 3)) > 0) Or Not f(3)) _
    
28.                    And ((f(5) And InStr(arr(i, 17), t(1, 5)) > 0) Or Not f(5)) Then
    
29.                     m = m + 1
    
30.                     For j = 1 To lc
    
31.                         brr(m, j) = arr(i, j)
    
32.                     Next
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.     End With
    
37.     Range("A5:S" & Rows.Count).ClearContents
    
38.     If m Then [a5].Resize(m, j - 1) = brr
    
39. End Sub

复制代码