提取Excel文件名称并统计每个EXCEL文件有几条数据

APPLE123

ykcbf1100 发表于 2024-7-24 20:07
附件供参考。。。

谢谢老师的帮助！

APPLE123

limonet 发表于 2024-7-24 20:20
空的忽略了，关键字：group by

谢谢老师的帮助！
请教老师。如果空的不忽略了，该怎么修改呢？
不理解，代码倒数第三行的参数为何是12？可否帮忙讲讲，谢谢！

limonet

加空，加循环，人力活，collection

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, Filename$, Arr() As Variant, Brr() As Variant, CS As New Collection, i%, j%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    Filename = Dir(Path & "*.xls")
    Do While Filename <> ""
        If Not Filename Like "*.xlsm" Then
            CS.Add Filename
            StrSQL = StrSQL & " Union All Select '" & Replace(Filename, ".", "' As Name,'") & _
            "' As Ex,* From [Excel 12.0;Database=" & Path & Filename & "].[Export$A2:A]"
        End If
        Filename = Dir
    Loop
    StrSQL = "Select name,Ex,Count(*) From (" & Mid(StrSQL, 12) & ") Group By name,Ex"
    Arr = Cn.Execute(StrSQL).GetRows
    Brr = Application.Transpose(Application.Transpose(Cn.Execute(StrSQL).GetRows(, , "Name")))
    For i = 1 To CS.Count
        If UBound(Filter(Brr, Split(CS(i), ".xls")(0))) = -1 Then
            j = UBound(Arr, 2) + 1
            ReDim Preserve Arr(0 To UBound(Arr), 0 To j)
            Arr(0, j) = Split(CS(i), ".")(0)
            Arr(1, j) = Split(CS(i), ".")(1)
            Arr(2, j) = 0
        End If
    Next i
    Range("B3").Resize(i - 1, 3) = Application.Transpose(Arr)
End Sub

APPLE123

quqiyuan 发表于 2024-7-24 20:22
参与一下，供参考。。。

谢谢老师的帮助！先消化一下。

APPLE123

limonet 发表于 2024-7-24 20:48
加空，加循环，人力活，collection

谢谢老师！修改代码又快又好！

limonet

不喜多次循环，recordcount

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, Filename$, Arr() As Variant, Rst As Object, i%
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    Filename = Dir(Path & "*.xls")
    Do While Filename <> ""
        If Not Filename Like "*.xlsm" Then
            StrSQL = "Select * From [Excel 12.0;Database=" & Path & Filename & "].[Export$A2:A]"
            Rst.Open StrSQL, Cn, 1, 3
            i = i + 1
            ReDim Preserve Arr(1 To 4, 1 To i)
            Arr(1, i) = i
            Arr(2, i) = Split(Filename, ".")(0)
            Arr(3, i) = Split(Filename, ".")(1)
            Arr(4, i) = Rst.RecordCount
            Rst.Close
        End If
        Filename = Dir
    Loop
    Range("A3").Resize(i, 4) = Application.Transpose(Arr)
End Sub

lsc900707

测试参考附件：

limonet

关键字：hdr=no