如何不打开工作簿，提取对应日期数据

gwjkkkkk

sql应该优选 。。。

按照通知

usedrange 发表于 2024-12-17 18:53
。。。。。。。。。。。。。。。

，效果很好，非常感谢

按照通知

z865593849 发表于 2024-12-17 16:05
WPS要安装access数据库引擎，不然就用OFFICE

用ofice试了，就是我想要的效果，感谢

ykcbf1100

参与一下，fso

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.18
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     fn = CStr(sh.[m1].Value)
   
7.     rq = CDate(Format(fn, "0000-00-00"))
   
8.     rq1 = VBA.DateAdd("yyyy", -1, rq)
   
9.     fn1 = Format(rq1, "yyyymmdd")
   
10.     ReDim brr(1 To 10000, 1 To 100)
    
11.     For Each f In fso.GetFolder(p).Files
    
12.         If fso.GetBaseName(f) = fn Then
    
13.             Set wb = Workbooks.Open(f, 0)
    
14.             arr = wb.Sheets(1).UsedRange
    
15.             wb.Close False
    
16.             For i = 1 To UBound(arr)
    
17.                 If arr(i, 1) <> Empty Then
    
18.                     m = m + 1
    
19.                     For j = 1 To UBound(arr, 2)
    
20.                         brr(m, j) = arr(i, j)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24.             m = m + 1
    
25.         End If
    
26.     Next f
    
27.     For Each f In fso.GetFolder(p).Files
    
28.         If fso.GetBaseName(f) = fn1 Then
    
29.             Set wb = Workbooks.Open(f, 0)
    
30.             arr = wb.Sheets(1).UsedRange
    
31.             wb.Close False
    
32.             For i = 1 To UBound(arr)
    
33.                 If arr(i, 1) <> Empty Then
    
34.                     m = m + 1
    
35.                     For j = 1 To UBound(arr, 2)
    
36.                         brr(m, j) = arr(i, j)
    
37.                     Next
    
38.                 End If
    
39.             Next
    
40.             m = m + 1
    
41.         End If
    
42.     Next f
    
43.     With sh
    
44.         .UsedRange.Offset(1).Clear
    
45.         .[a1].Resize(m, UBound(arr, 2)) = brr
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码