遍历文件夹统计个数

jiaqitang

我文件夹里有 100多个文件，表在SHEET1， 格式相同，每个表都有 ID这一列（ID有重复i）。 我想在同一文件夹里做个SUMMAY表， SUMMAY表里A列就是每个文件名字， B列是每个文件里ID总数（包括重复ID）， C列是非重复ID数。



总ID数并不是总等于表里最后一个ID的行数减1， 因为这些表是从其它数据源导入EXCELl里的，有时候有很多空白行。。。


100多个文件，每个表有几万行，用PQ很慢，VAB能快些吧，怎么实现？

请看附件例子

liulang0808

Sub 按钮1_Click()
    Dim arr(1 To 200, 1 To 3)
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlManual
    r = 0
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            d.RemoveAll
            With Workbooks.Open(f)
                brr = .Sheets(1).UsedRange
                For j = 2 To UBound(brr)
                    If Len(brr(j, 1)) > 0 Then
                        d(brr(j, 1)) = d(brr(j, 1)) + 1
                    End If
                Next j
                .Close False
            End With
            r = r + 1
            arr(r, 1) = fso.getbasename(f)
            arr(r, 2) = WorksheetFunction.Sum(d.items)
            arr(r, 3) = d.Count
        End If
    Next f
    Sheets("Summary").[a2].Resize(r, 3) = arr
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

打开文件再统计的方式，效率不一定高，供参考

micch

mark,等一个SQL的答案

jiaqitang

谢谢大佬，难道还有不打开文件就能统计的。

opiona

SQL可参考  : https://club.excelhome.net/thread-1409141-1-1.html

cui26896

有错误，重新上传附件
请参考附件SQL方法
遍历文件夹统计个数(cui26896).zip (74.9 KB, 下载次数: 8)

2023-4-3 20:20 上传

点击文件名下载附件

cui26896

1. Sub test()
   
2.   Dim Cn As Object, Rs As Object, d As Object, p$, f$, Sq$, SqB$, i&, j&, k&
   
3.   Cells.ClearContents
   
4.   Application.ScreenUpdating = False
   
5.   Set d = CreateObject("Scripting.Dictionary")
   
6.   Set Cn = CreateObject("ADODB.Connection")
   
7.   Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
8.   p = ThisWorkbook.path & ""
   
9.   f = Dir(p & "*.xlsx")
   
10.   Do While f <> ""
    
11.     If f <> ThisWorkbook.Name Then
    
12.       k = k + 1
    
13.       Sq = "select '" & Replace(f, ".xlsx", " ") & "' as 文件名, count(id) as 总ID数 FROM [Excel 12.0;Database=" & p & f & "].[Sheet1$]"
    
14.       SqB = "select '" & Replace(f, ".xlsx", " ") & "' as 文件名,count(id) as 非重ID数 from(select id FROM [Excel 12.0;Database=" & p & f & "].[Sheet1$] group by id)"
    
15.       Sq = "select a.文件名,a.总ID数,b.非重ID数 from (" & Sq & ")a left join (" & SqB & ")b on b.文件名= a.文件名"
    
16.       d(Sq) = ""
    
17.       If k Mod 49 = 0 Then
    
18.         i = i + 1
    
19.         Sq = Join(d.Keys, " UNION ALL ")
    
20.         d.RemoveAll
    
21.         Set Rs = Cn.Execute(Sq)
    
22.         If i = 1 Then
    
23.           For j = 0 To Rs.Fields.Count - 1
    
24.             Range("A1").Offset(0, j) = Rs.Fields(j).Name
    
25.           Next
    
26.         End If
    
27.         Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
    
28.       End If
    
29.     End If
    
30.     f = Dir
    
31.   Loop
    
32.   If d.Count > 0 Then
    
33.     Sq = Join(d.Keys, " UNION ALL ")
    
34.     Set Rs = Cn.Execute(Sq)
    
35.     If i = 0 Then
    
36.       For j = 0 To Rs.Fields.Count - 1
    
37.         Range("A1").Offset(0, j) = Rs.Fields(j).Name
    
38.       Next
    
39.     End If
    
40.     Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
    
41.   End If
    
42.   Cn.Close
    
43.   Set Cn = Nothing
    
44.   Set Rs = Nothing
    
45.   Set d = Nothing
    
46.   Application.ScreenUpdating = True
    
47.   Beep
    
48. End Sub

复制代码

fzxba

参与.rar (70.18 KB, 下载次数: 12)

2023-4-3 18:17 上传

点击文件名下载附件

jiaqitang

cui26896 发表于 2023-4-3 17:17
有错误，重新上传附件
请参考附件SQL方法

两段代码，哪一个是对的？