老师们给看看这个按条件汇总的问题

llwwll

     首先感谢“opiona”老师的帖子https://club.excelhome.net/threa ... tml?_dsign=adda4976

我这个表就是想用这个“5_多工作簿指定工作表，全部数据汇总” 修改，之前没接触过vba纯新手，看了俩天也不会修改，想 请大家帮帮忙。
各工作簿格式统一，工作表格式也统一、
想实现1、选择特定文件夹内工作簿内的指定工作表统计（可以实现有俩个条件吗？指定名称1工作表和名称指定2工作表进行统计，不好实现就不需要）
          2、目前使用“opiona”老师的这个表第三行有些有字符输入后报错
          3、可以不用写入标题，在汇总表中可以用一行固定用做
          4 、汇总出结果后想实现一个查找输出一个工作表的功能，汇总表有结果后再汇总表第一列或最后一列输入编码后查找出的结果输出在汇总表之后的工作表中。
第4条功能不重要，主要还是想实现多簿指定表中内容统计。新手不懂麻烦大家帮帮吗。

llwwll

自己顶起来，有没有人看看呀

shiruiqiang

按shift多选文件

shiruiqiang

等审核吧，献丑

按shift选择需要统计的表

llwwll

llwwll 发表于 2024-9-28 20:56
自己顶起来，有没有人看看呀

谢谢帮助，正看你写的呢

llwwll

谢谢帮助，正在学习你写的

llwwll

第三行特殊字符报错是因为有换行符，加入下面代码
有的表标题含有：换行符，英文的句号
SQL无法识别，要进行替换 。   
“Rem 组合查询标题
    StrBT = ""
    For ICOL = 3 To SH1.Range("HZ3").End(xlToLeft).Column
    Rem 替换掉[.]=[#],换行符=[_]
        StrBT = StrBT & ",[" & Replace(Replace(Replace(Replace(SH1.Cells(3, ICOL).Value, ".", "#"), vbCrLf, "_"), vbCr, "_"), vbLf, "_") & "]"
    Next”

llwwll

shiruiqiang 发表于 2024-9-28 23:04
等审核吧，献丑

按shift选择需要统计的表

刚看到附件，写的挺好的，运行完美，就是我说的不是选择多个工作簿，而是工作簿里面的工作表，就是我表里面的9.25/9.26/9.27，现在是在B2里面输入需要查询的工作表名称查询，想实现查询多个表怎么实现呢

ykcbf1100

新写一个吧，字典+fso

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2024.9.29
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("汇总")
   
7.     With sh
   
8.         c = .Cells(3, "XFD").End(1).Column
   
9.         For j = 4 To c
   
10.             s = .Cells(3, j).Value
    
11.             d(s) = j
    
12.         Next
    
13.         bt = .[b1].Value
    
14.         bm = CStr(.[b2].Value)
    
15.     End With
    
16.     ReDim brr(1 To 10000, 1 To 100)
    
17.     For Each f In fso.GetFolder(p).Files
    
18.         If LCase(f.Name) Like "*.xls*" Then
    
19.             If InStr(f, "~$") = 0 Then
    
20.                 If InStr(f, ThisWorkbook.Name) = 0 Then
    
21.                     Set wb = Workbooks.Open(f, 0)
    
22.                     fn = fso.GetBaseName(f)
    
23.                     With wb.Sheets(bm)
    
24.                         r = .Cells(Rows.Count, 1).End(3).Row
    
25.                         c1 = .Cells(1, "XFD").End(1).Column
    
26.                         arr = .[a1].Resize(r, c1)
    
27.                     End With
    
28.                     wb.Close 0
    
29.                     For I = 2 To UBound(arr)
    
30.                         M = M + 1
    
31.                         brr(M, 1) = fn
    
32.                         brr(M, 2) = bm
    
33.                         brr(M, 3) = M
    
34.                         For j = 1 To UBound(arr, 2)
    
35.                             s = arr(1, j)
    
36.                             If d.exists(s) Then
    
37.                                 brr(M, d(s)) = arr(I, j)
    
38.                             End If
    
39.                         Next
    
40.                     Next
    
41.                     
    
42.                 End If
    
43.             End If
    
44.         End If
    
45.     Next
    
46.     With sh
    
47.         .UsedRange.Offset(3).Clear
    
48.         With .[a4].Resize(M, c)
    
49.             .Value = brr
    
50.             .Borders.LineStyle = 1
    
51.             .HorizontalAlignment = xlCenter
    
52.             .VerticalAlignment = xlCenter
    
53.         End With
    
54.     End With
    
55.     Set d = Nothing
    
56.     Application.ScreenUpdating = True
    
57.     MsgBox "OK！"
    
58. End Sub
    
59. 
    

复制代码