（VBA数据引用）无良老板又双叒叕发来奇奇怪怪的任务，各路高手请伸出援助之手

不读圣贤书

大致这么个情况
1个汇总表
1个数据文件夹 （里面大概会有7 8 组）
数据文件夹里每天更新数据进去，文件名格式就是年月日
目的呢
汇总文件需要实现 一键查询指定日期的  各组数据

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False
   
3. Dim arr, i, p, xb As Workbook, dic, s
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. s = Sheet1.[a1].Value
   
6. arr = Sheet1.Range("a3").CurrentRegion.Value
   
7. p = ThisWorkbook.Path & "\数据"
   
8. For c = 2 To 3
   
9.     Set xb = Workbooks.Open(p & arr(1, c) & "" & s & ".xlsx", 0)
   
10.         ar = xb.Sheets(1).Range("a1").CurrentRegion.Value
    
11.     xb.Close (0)
    
12.     dic.RemoveAll
    
13.     For i = 1 To UBound(ar)
    
14.         If Not dic.exists(arr(i, 1)) Then
    
15.             dic(ar(i, 1)) = ar(i, 2)
    
16.         Else
    
17.             dic(ar(i, 1)) = dic(s) + ar(i, 2)
    
18.         End If
    
19.     Next
    
20.     For r = 2 To UBound(arr)
    
21.         If dic.exists(arr(r, 1)) Then
    
22.         arr(r, c) = dic(arr(r, 1))
    
23.         End If
    
24.     Next
    
25. Next c
    
26. Sheet1.Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
27. Application.ScreenUpdating = True
    
28. Set dic = Nothing
    
29. End Sub

复制代码

Qs18

试试。。。。。。。

Qs18

试试。。。。。

quqiyuan

根据数据源全自动生成，仅供参考。。。

ykcbf1100

全表自动生成

附件供参考

ykcbf1100

参与一下...

1. Sub ykcbf()   '//2024.9.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     rq = CStr(sh.[a1].Value)
   
8.     p = ThisWorkbook.Path & "\数据"
   
9.     ReDim brr(1 To 10000, 1 To 100)
   
10.     M = 1: n = 1
    
11.     brr(1, 1) = "名称"
    
12.     For Each fd In fso.GetFolder(p).SubFolders
    
13.         fds = fd.Name
    
14.         If Not d.exists(fds) Then
    
15.             n = n + 1
    
16.             d(fds) = n
    
17.             brr(1, n) = fd.Name
    
18.         End If
    
19.         c = d(fd.Name)
    
20.         For Each f In fd.Files
    
21.             fn = fso.GetBaseName(f)
    
22.             If fn = rq Then
    
23.                 Set wb = Workbooks.Open(f, 0)
    
24.                 With wb.Sheets("Sheet1")
    
25.                     r = .Cells(Rows.Count, 1).End(3).Row
    
26.                     arr = .[a1].Resize(r, 2)
    
27.                 End With
    
28.                 wb.Close 0
    
29.                 For i = 1 To UBound(arr)
    
30.                     s = arr(i, 1)
    
31.                     If Not d.exists(s) Then
    
32.                         M = M + 1
    
33.                         d(s) = M
    
34.                         brr(M, 1) = s
    
35.                     End If
    
36.                     r = d(arr(i, 1))
    
37.                     brr(r, c) = arr(i, 2)
    
38.                 Next
    
39.             End If
    
40.         Next
    
41.     Next
    
42.     With sh
    
43.         .[a3].Resize(10000, 100).Clear
    
44.         .[a3].Resize(1, n).Interior.Color = 49407
    
45.         With .[a3].Resize(M, n)
    
46.             .Value = brr
    
47.             .Borders.LineStyle = 1
    
48.             .HorizontalAlignment = xlCenter
    
49.             .VerticalAlignment = xlCenter
    
50.         End With
    
51.     End With
    
52.     Set d = Nothing
    
53.     Application.ScreenUpdating = True
    
54.     MsgBox "OK！"
    
55. End Sub
    

复制代码

quqiyuan

刚才睡觉去，忘了上传了，仅供参考。。。

quqiyuan

代码如下。。。
Public col As New Collection, s As Variant
Sub test()
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set sht = wb.Sheets(1)
    s = sht.[a1].Value
    p = wb.Path & "\"
    Set fso = CreateObject("scripting.filesystemobject")
    Set d = CreateObject("scripting.dictionary")
    m = 1: n = 1
    ReDim brr(1 To 10000, 1 To 100)
    brr(1, 1) = "名称"
    Call 子目录(fso, p)
    For i = 1 To col.Count
        m = m + 1
        x = Len(col(i)) - Len(Replace(col(i), "\", ""))
        ss = Split(col(i), "\")(x - 1)
        brr(1, m) = ss
        With Workbooks.Open(col(i), 0).Sheets(1)
            arr = .[a1].CurrentRegion
            .Parent.Close 0
        End With
        For j = 1 To UBound(arr)
            sss = arr(j, 1)
            If Not d.exists(sss) Then n = n + 1: d(sss) = n
            nn = d(sss)
            brr(nn, 1) = sss
            brr(nn, m) = brr(nn, m) + arr(j, 2)
        Next
    Next
    sht.[l3].Resize(n, m) = brr
    Beep
    Set col = New Collection
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub

Sub 子目录(fso, p)
    For Each file In fso.getfolder(p).Files
        If InStr(file, s) And Left(file.Name, 2) <> "~$" Then col.Add file.Path
    Next
    For Each folder In fso.getfolder(p).subfolders
         子目录 fso, folder
    Next
End Sub

ZHLK

供参考
'先给数据表加标题
Sub demo()
Dim cnn As Object, rst As Object
Dim strPath As String, strCnn As String, strSQL As String
Dim i As Long
Set cnn = CreateObject("adodb.connection")
arr = Array("1组", "2组")
For i = 0 To UBound(arr)

    strPath = ThisWorkbook.Path & "\数据\" & arr(i) & "\" & Cells(1, 1).Value & ".xlsx" '指定工作簿
    If Dir(strPath) <> "" Then
        strCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & strPath
        cnn.Open strCnn
        strSQL = "SELECT shuliang FROM [sheet1$]"
        Set rst = cnn.Execute(strSQL)
        Cells(4, 2 + i).CopyFromRecordset rst
      End If
     cnn.Close
Next
Set cnn = Nothing

End Sub