|
本帖最后由 cui26896 于 2023-4-4 07:57 编辑
- Sub test()
- Dim Cn As Object, Rs As Object, d As Object, p$, f$, Sq$, SqB$, i&, j&, k&
- Cells.ClearContents
- Application.ScreenUpdating = False
- Set d = CreateObject("Scripting.Dictionary")
- Set Cn = CreateObject("ADODB.Connection")
- Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
- p = ThisWorkbook.path & ""
- f = Dir(p & "*.xlsx")
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- k = k + 1
- Sq = "select '" & Replace(f, ".xlsx", " ") & "' as 文件名, count(id) as 总ID数 FROM [Excel 12.0;Database=" & p & f & "].[Sheet1$]"
- SqB = "select '" & Replace(f, ".xlsx", " ") & "' as 文件名,count(id) as 非重ID数 from(select id FROM [Excel 12.0;Database=" & p & f & "].[Sheet1$] group by id)"
- Sq = "select a.文件名,a.总ID数,b.非重ID数 from (" & Sq & ")a left join (" & SqB & ")b on b.文件名= a.文件名"
- d(Sq) = ""
- If k Mod 49 = 0 Then
- i = i + 1
- Sq = Join(d.Keys, " UNION ALL ")
- d.RemoveAll
- Set Rs = Cn.Execute(Sq)
- If i = 1 Then
- For j = 0 To Rs.Fields.Count - 1
- Range("A1").Offset(0, j) = Rs.Fields(j).Name
- Next
- End If
- Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
- End If
- End If
- f = Dir
- Loop
- If d.Count > 0 Then
- Sq = Join(d.Keys, " UNION ALL ")
- Set Rs = Cn.Execute(Sq)
- If i = 0 Then
- For j = 0 To Rs.Fields.Count - 1
- Range("A1").Offset(0, j) = Rs.Fields(j).Name
- Next
- End If
- Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
- End If
- Cn.Close
- Set Cn = Nothing
- Set Rs = Nothing
- Set d = Nothing
- Application.ScreenUpdating = True
- Beep
- End Sub
复制代码 |
|