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

APPLE123

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


1、文件夹内有200多个文件，有word、Excel、jpg、png等，但仅提取Excel工作簿文件名称到本工作表的B列。
2、根据Excel文件的第一个工作表数据记录数（每个工作簿的数据行数不等），在C列填写记录数。
注意，Excel文件名称命名无规则，但是工作表的第一行、第二行是一样的，表格名称和表格字段名称。其他是数据，一行数据作为一条记录，10行（不含表格名称和表格字段名称所在行）数据，就是10条记录。
3、个别工作簿内可能没有有效数据，即仅有第一行、第二行，如辅助表F公司.xls
     大多数工作簿的后缀名称为.xls，个别工作簿的后缀名称为.xlsx，如辅助表G公司.xlsx

提取结果如本工作表。
请老师帮帮忙，使用vba提取，谢谢！

小凡、、、

=一哈 这是什么个情况 第一次遇到，xlsm的文件CreateObject 会读取出来两个？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.24
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 10)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = fso.GetBaseName(f)
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 m = m + 1
    
13.                 brr(m, 1) = m
    
14.                 brr(m, 2) = fn
    
15.                 brr(m, 3) = fso.GetExtensionName(f)
    
16.                 With wb.Sheets(1)
    
17.                     r = .Cells(Rows.Count, 1).End(3).Row
    
18.                     brr(m, 4) = r - 2
    
19.                     If brr(m, 4) = 0 Then brr(m, 5) = "没有有效数据!"
    
20.                     If brr(m, 3) = "xlsx" Then brr(m, 5) = "后缀名称为.xlsx"
    
21.                 End With
    
22.                 wb.Close 0
    
23.             End If
    
24.         End If
    
25.     Next f
    
26.     With sh
    
27.         .[a3:e1000].Clear
    
28.         With .[a3].Resize(m, 5)
    
29.             .Value = brr
    
30.             .Borders.LineStyle = 1
    
31.             .HorizontalAlignment = xlCenter
    
32.             .VerticalAlignment = xlCenter
    
33.         End With
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

ykcbf1100

小凡、、、 发表于 2024-7-24 20:04
=一哈 这是什么个情况 第一次遇到，xlsm的文件CreateObject 会读取出来两个？

正常的，一个是临时文件，带 ^$开头的
用下面这个语句可以避开这个坑：If InStr(f.Name, ThisWorkbook.Name) = 0 Then

limonet

空的忽略了，关键字：group by

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, Filename$
    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
            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"
    Range("B3").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet, p$, f$, biaoti, brr
    Set wb = ThisWorkbook
    p = wb.Path & "\"
    f = Dir(p & "*.xls*")
    biaoti = [{"序号","提取excel工作簿文件名称","后缀名","记录数","备注"}]
    ReDim brr(1 To 10000, 1 To 5)
    Do While f <> ""
        If f <> wb.Name Then
            With Workbooks.Open(p & f, 0).Sheets(1)
                n = n + 1
                brr(n, 1) = n
                brr(n, 2) = Left(.Parent.Name, InStrRev(.Parent.Name, ".") - 1)
                brr(n, 3) = Mid(.Parent.Name, InStrRev(.Parent.Name, ".") + 1)
                brr(n, 4) = .UsedRange.Rows.Count - 2
                If brr(n, 4) = 0 Then brr(n, 5) = "没有有效数据"
                If LCase(brr(n, 3)) = "xlsx" Then brr(n, 5) = "后缀名称为." & brr(n, 3)
                .Parent.Close 0
            End With
        End If
        f = Dir
    Loop
    With Sheet1
        .UsedRange.ClearContents
        .[a1] = "辅助表信息表"
        .[a1:e1].Merge
        .[a2].Resize(, 5) = biaoti
        .[a3].Resize(n, 5) = brr
    End With
End Sub

ykcbf1100

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

按题意，不能把记录为空的文件忽略，还要在E列说明一下。