求大佬帮忙，我这里放了4个工作簿，实际上我有800+个，每个工作簿只有1页，我需要...

菜鸟想学

求大佬帮忙，我这里放了4个工作簿，实际上我有800+个，每个工作簿只有1页，我需要根据科目编码，查询到每个表中相应科目的辅助核算，还需要带出文件名

mafect

静待大佬出现

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.25
   
2.     Dim arr, brr(1 To 10000, 1 To 4)
   
3.     Set Fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     st = sh.[c1].Value
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If f.Name Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = Fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 With wb.Sheets(1)
    
14.                     r = .Cells(Rows.Count, 1).End(3).Row
    
15.                     arr = .Range("a7:h" & r)
    
16.                     c1 = Application.WorksheetFunction.Match("科目名称", .Rows(7), 0)
    
17.                     c2 = Application.WorksheetFunction.Match("辅助核算", .Rows(7), 0)
    
18.                     wb.Close False
    
19.                 End With
    
20.                 For i = 2 To UBound(arr)
    
21.                     If CStr(arr(i, 1)) = CStr(st) Then
    
22.                         m = m + 1
    
23.                         brr(m, 1) = m
    
24.                         brr(m, 2) = arr(i, c1)
    
25.                         brr(m, 3) = arr(i, c2)
    
26.                         brr(m, 4) = fn
    
27.                     End If
    
28.                 Next
    
29.             End If
    
30.         End If
    
31.     Next f
    
32.     On Error Resume Next
    
33.     With sh
    
34.         .UsedRange.Offset(2).Clear
    
35.         With .[a3].Resize(m, 4)
    
36.             .Value = brr
    
37.             .Borders.LineStyle = 1
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.         End With
    
41.     End With
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

opiona

https://club.excelhome.net/thread-1409141-1-1.html

wengjl

给个思路：
1. 在查询工作簿，增加一张表，将目录下的800多个文件读取到表中
2. 查询时，对新增的表进行循环，依次打开表，读取符合条件的记录到查询表，再关闭表，打开下一个表
3. 循环结束，查询完成

写代码有点烦

sdytsxd991122

如果真有800个文件，建议用SQL查询

fzxba

辅助核算查询sql.zip (398.91 KB, 下载次数: 23)

2024-1-25 12:17 上传

点击文件名下载附件

EHGOOD

800+表，建议不要用每个表workbooks.open来获取数据。

菜鸟想学

fzxba 发表于 2024-1-25 12:17

有几个科目编码太长，就查不到了，比如这个1462020101010201