精准查询的问题

杨小妹

附件 精准查询附件.rar (776.21 KB, 下载次数: 16)

2024-8-7 16:14 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.7
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     With sh
   
7.         .[c2:f10000].ClearContents
   
8.         r1 = sh.[a1].Value
   
9.         st = sh.[a2].Value
   
10.         zrr = .[c1:e1]
    
11.     End With
    
12.     p = ThisWorkbook.Path & ""
    
13.     ReDim brr(1 To 10000, 1 To 4)
    
14.     For Each f In fso.GetFolder(p).Files
    
15.         If LCase$(f.Name) Like "*.xlsb" Then
    
16.             fn = fso.GetBaseName(f)
    
17.             Set wb = Workbooks.Open(f, 0)
    
18.             With wb.Sheets(1)
    
19.                 r = .Cells(Rows.Count, 1).End(3).Row
    
20.                 c = .Cells(1, "XFD").End(1).Column
    
21.                 arr = .[a1].Resize(r, c)
    
22.             End With
    
23.             wb.Close False
    
24.             For j = 1 To UBound(arr, 2)
    
25.                 If arr(r1, j) = st Then
    
26.                     m = m + 1
    
27.                     jj = j
    
28.                     For x = 1 To UBound(zrr, 2)
    
29.                         brr(m, x) = arr(zrr(1, x), jj)
    
30.                     Next
    
31.                     brr(m, 4) = fn & 列号转列符(jj)
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next f
    
36.     With sh
    
37.         If m > 0 Then
    
38.             .[c2].Resize(m, 4) = brr
    
39.         Else
    
40.             MsgBox "没查到对应数据！请重新输入数据查询！"
    
41.             Exit Sub
    
42.         End If
    
43.     End With
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub

复制代码

小凡、、、

参与一下----