代码如下。。。
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
|