跨表时段多条件模糊匹配查找提取数据

feilanga

1. Sub 清空()
   
2.     Sheet1.Range("C8").Resize(1000, 14).ClearContents
   
3.     Sheet1.Range("C8:O1000").Borders.LineStyle = xlNone
   
4. End Sub
   
5. Sub 模糊筛选()
   
6.     Dim m As Boolean
   
7.     Dim my()
   
8.     Dim arr()
   
9.     Dim sht As Worksheet
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> "查询" Then
    
12.             If sht.Index > 1 Then
    
13.                 temp = sht.UsedRange
    
14.                 表名 = sht.Name
    
15.                 For i = 2 To UBound(temp)
    
16.                     If temp(i, 1) <> "" Then
    
17.                         b = b + 1
    
18.                         ReDim Preserve my(1 To 14, 1 To b)
    
19.                         my(14, b) = 表名
    
20.                         For j = 1 To UBound(temp, 2)
    
21.                             my(j, b) = temp(i, j)
    
22.                         Next
    
23.                     End If
    
24.                 Next
    
25.             End If
    
26.         End If
    
27.     Next
    
28.     ReDim arr(1 To b, 1 To 14)
    
29.     For i = 1 To b
    
30.         For j = 1 To 14
    
31.             arr(i, j) = my(j, i)
    
32.         Next
    
33.     Next
    
34.     工作表名称 = Sheet1.Range("B5").Value
    
35.     记录类别 = Sheet1.Range("C5").Value
    
36.     供应商名称 = Sheet1.Range("E5").Value
    
37.     物资代码 = Sheet1.Range("F5").Value
    
38.     物资名称 = Sheet1.Range("G5").Value
    
39.     物资规格 = Sheet1.Range("H5").Value
    
40.     单位 = Sheet1.Range("I5").Value
    
41.     数量 = Sheet1.Range("J5").Value
    
42.     单价 = Sheet1.Range("K5").Value
    
43.     金额 = Sheet1.Range("L5").Value
    
44.     使用部门 = Sheet1.Range("M5").Value
    
45.     部门签收 = Sheet1.Range("N5").Value
    
46.     备注 = Sheet1.Range("O5").Value
    
47.     If Trim(CStr(Sheet1.Range("D5").Value)) = "" Then
    
48.         起始日期 = CDate("1900-01-01")
    
49.     Else
    
50.         起始日期 = CDate(Trim(CStr(Sheet1.Range("D5").Value)))
    
51.     End If
    
52.     If Trim(CStr(Sheet1.Range("D6").Value)) = "" Then
    
53.         结束日期 = CDate("2100-12-31")
    
54.     Else
    
55.         结束日期 = CDate(Trim(CStr(Sheet1.Range("D6").Value)))
    
56.     End If
    
57.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
    
58.     For i = 2 To UBound(arr)
    
59.         If arr(i, 1) <> "" Then
    
60.             m = True
    
61.             If CDate(arr(i, 2)) >= 起始日期 And CDate(arr(i, 2)) <= 结束日期 Then
    
62.                 If 工作表名称 <> "" And (InStr(arr(i, 14), 工作表名称) = 0) Then
    
63.                     m = False
    
64.                 End If
    
65.                 If 记录类别 <> "" And (InStr(arr(i, 1), 记录类别) = 0) Then
    
66.                     m = False
    
67.                 End If
    
68.                
    
69.                 If 供应商名称 <> "" And (InStr(arr(i, 3), 供应商名称) = 0) Then
    
70.                     m = False
    
71.                 End If
    
72.                 If 物资代码 <> "" And (InStr(arr(i, 4), 物资代码) = 0) Then
    
73.                     m = False
    
74.                 End If
    
75.                 If 物资名称 <> "" And (InStr(arr(i, 5), 物资名称) = 0) Then
    
76.                     m = False
    
77.                 End If
    
78.                 If 物资规格 <> "" And (InStr(arr(i, 6), 物资规格) = 0) Then
    
79.                     m = False
    
80.                 End If
    
81.                 If 单位 <> "" And (InStr(arr(i, 7), 单位) = 0) Then
    
82.                     m = False
    
83.                 End If
    
84.                 If 数量 <> "" And (InStr(arr(i, 8), 数量) = 0) Then
    
85.                     m = False
    
86.                 End If
    
87.                 If 单价 <> "" And (InStr(arr(i, 9), 单价) = 0) Then
    
88.                     m = False
    
89.                 End If
    
90.                 If 金额 <> "" And (InStr(arr(i, 10), 金额) = 0) Then
    
91.                     m = False
    
92.                 End If
    
93.                 If 使用部门 <> "" And (InStr(arr(i, 11), 使用部门) = 0) Then
    
94.                     m = False
    
95.                 End If
    
96.                 If 部门签收 <> "" And (InStr(arr(i, 12), 部门签收) = 0) Then
    
97.                     m = False
    
98.                 End If
    
99.                 If 备注 <> "" And (InStr(arr(i, 13), 备注) = 0) Then
    
100.                     m = False
     
101.                 End If
     
102.                
     
103.                 If m = True Then
     
104.                     k = k + 1
     
105.                     For j = 1 To UBound(arr, 2) - 1
     
106.                         brr(k, j) = arr(i, j)
     
107.                     Next
     
108.                 End If
     
109.             End If
     
110.         End If
     
111.     Next
     
112.     Call 清空
     
113.     If k > 0 Then
     
114.         Sheet1.Range("C8").Resize(k, UBound(brr, 2)) = brr
     
115.         Sheet1.Range("C8:O" & CStr(k + 7)).Borders.LineStyle = xlContinuous
     
116.     Else
     
117.         MsgBox "查询无数据"
     
118.     End If
     
119. End Sub

复制代码

SCWYZJ

非常感谢各位老师的热心帮助，试了下，只有11楼老师的最符合我的要求，11楼老师的是匹配所有表的，也非常好，也需要。其他几位老师的不能多条件模糊匹配。再次感谢。

SCWYZJ

feilanga 发表于 2024-6-22 08:57

老师，我想在【记录类别】前面添加上自动序号，如何修改代码

wang-way

SCWYZJ 发表于 2024-6-22 20:22
非常感谢各位老师的热心帮助，试了下，只有11楼老师的最符合我的要求，11楼老师的是匹配所有表的，也非常好 ...

我的代码有什么问题  ？ 那个模糊查询 只要稍微修改一下列号 就可以了 。 我是分日期 精确匹配列 模糊匹配列的 你研究一下代码 调整一下列号

SCWYZJ

feilanga 发表于 2024-6-22 08:57

老师，为什么我的查询表在sheet2时，代码报错在日期判断那段？因为我的Excel文件中，不光只有ABC三个sheet表，还有其它格式不同的很多表，你的代码能否改成比较通用实用的效果呢？谢谢

feilanga

3个文件,1个是新加入编号的,1个是代码注释的,1个是你红框里的代码精简掉的. 怎么说呢,之前的红框代码也不能说多余,这段代码对数据源的数据做了一个清洗,如果数据规范,红框代码可以不要,保留也不影响啥. 总之,原来的代码考虑的情况比较多 . 适合更多复杂情况.和多种查询要求  代码已经注释,按需求修改.

feilanga

红框代码是为了给abc表在内存里面加上一列标注分表名称，这样就可以任选查询abc表了 去掉以后 只能查询指定表

ykcbf1100

选定工作表后，日期条件可以一个为空，也可以二个全为空，也可以都有日期，其它查询字段模糊查询
例1：开始日期不为空，结束日期为空，则大于等于开始日期的所有满足其它条件的数据列出；
例2：开始日期为空，结束日期不为空，则小于等于结束日期的所有满足其它条件的数据列出；
例3：开始日期不为空，结束日期不为空，则大于等于开始日期、且小于等于结束日期的所有满足其它条件的数据列出；

ykcbf1100

多条件模糊查询。。。

1. Sub ykcbf()  '//2024.6.23
   
2.     Dim arr, brr
   
3.     Set Sh = ThisWorkbook.Sheets("查询")
   
4.     c = 13
   
5.     ReDim a(1 To c), b(1 To c), ft(1 To c)
   
6.     With Sh
   
7.         For x = 1 To 13
   
8.             a(x) = .Cells(5, x + 2): b(x) = x
   
9.         Next
   
10.         bm = .[b5].Value
    
11.         rq1 = .[d5].Value
    
12.         rq2 = .[d6].Value
    
13.     End With
    
14.     bb = [{1,3,4,5,6,7,8,9,10,11,12,13}]
    
15.     arr = Sheets(bm).UsedRange
    
16.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
17.     For i = 2 To UBound(arr)
    
18.         fft = 1: Sum = 0
    
19.         p1 = IIf(rq1 = Empty And rq2 = Empty, 1, 0)
    
20.         Sum = Sum + p1
    
21.         p1 = IIf(rq1 = Empty And rq2 <> Empty And arr(i, 2) <= rq2, 1, 0)
    
22.         Sum = Sum + p1
    
23.         p1 = IIf(rq1 <> Empty And rq2 = Empty And arr(i, 2) >= rq1, 1, 0)
    
24.         Sum = Sum + p1
    
25.         p1 = IIf(arr(i, 2) >= rq1 And arr(i, 2) <= rq2, 1, 0)
    
26.         Sum = Sum + p1
    
27.         fft = fft * Sum
    
28.         For x = 1 To UBound(bb)
    
29.             ft(x) = IIf(a(bb(x)) = Empty Or arr(i, bb(x)) Like "*" & a(bb(x)) & "*", 1, 0)
    
30.             fft = fft * ft(x)
    
31.         Next
    
32.         If fft = 1 Then
    
33.             m = m + 1
    
34.             For j = 1 To UBound(arr, 2)
    
35.                 brr(m, j) = arr(i, j)
    
36.             Next
    
37.         End If
    
38.     Next
    
39.     If m > 0 Then
    
40.         With Sh
    
41.             .[a8:z1000].ClearContents
    
42.             .[c8].Resize(m, 13) = brr
    
43.             .[c8].Resize(m, 13).Borders.LineStyle = 1
    
44.         End With
    
45.     End If
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码

7993708

feilanga 发表于 2024-6-23 00:36
红框代码是为了给abc表在内存里面加上一列标注分表名称，这样就可以任选查询abc表了 去掉以后 只能查询指定 ...

没想到老师,VBA也这么历害。。。。如果可以不区分大小写就更完美