请问将多个excel表的文件名和每个表的行数统计出来

northwolves

格式相同时,建议使用ADO+SQL:

Sub test()
Dim f As String, t As String, r
With CreateObject("ADODB.connection")
f = Dir("d:\data\*.xls")
While f > ""
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0';Data Source=d:\data\" & f
r = .Execute("select count(标题2) from [sheet1$a:b] group by 标题2").getrows
.Close
t = t & f & vbTab & r(0, 0) & vbCrLf
f = Dir
Wend
End With
MsgBox t
End Sub

GoTop

QUOTE:

以下是引用vinsine在2008-9-24 18:19:00的发言：

输出格式是怎样的？上传个样式表拉

输出格式没什么特殊要求，就是一列是文件的名字，一列是行数

如附件所示

5H4pvC6K.rar (1.68 KB, 下载次数: 1)

2008-9-24 20:16 上传

点击文件名下载附件
请问将多个excel表的文件名和每个表的行数统计出来

GoTop

QUOTE:

以下是引用northwolves在2008-9-24 18:40:00的发言：

格式相同时,建议使用ADO+SQL:

Sub test()
Dim f As String, t As String, r
With CreateObject("ADODB.connection")
f = Dir("d:\data\*.xls")
While f > ""
.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0';Data Source=d:\data\" & f
r = .Execute("select count(标题2) from [sheet1$a:b] group by 标题2").getrows
.Close
t = t & f & vbTab & r(0, 0) & vbCrLf
f = Dir
Wend
End With
MsgBox t
End Sub

版主，我运行你的代码后出现错误提示

[此贴子已经被作者于2008-9-24 20:22:42编辑过]

vinsine

Sub Test()
 Dim fso As New FileSystemObject
 Dim fFile As Object
 Dim strFileName As String
 Dim strFile As String
 Dim intRow As Integer
 Dim fromPath As String

 Dim xlBook As New Excel.Workbook
 Dim xlSheet As New Excel.Worksheet
 
 fromPath = "C:\NewHTV" '指定文件夹

 If Right(fromPath, 1) <> "\" Then fromPath = fromPath & "\"
 
 
 
 
    For Each fFile In fso.GetFolder(fromPath).Files
    If UCase(Right(fFile.Name, 3)) = "XLS" Then
     strFileName = fFile.Name
     Set xlBook = Workbooks.Open(fromPath & fFile.Name)
     Set xlSheet = xlBook.Sheets(1)
     intRow = xlSheet.UsedRange.Rows.Count
     'strFileInfo = strFileName & "包含" & intRow & "行"
     strFileInfo = strFileInfo & "'" & strFileName
     strFileRow = strFileRow & "'" & intRow
     xlBook.Close
     Set xlBook = Nothing
    End If
     Next
    
'MsgBox strFile
arrFileName = Split(strFileInfo, "'")
arrFileRow = Split(strFileRow, "'")

Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)

'选择第一行第一列开始写写文件名
k = 1
For i = 1 To UBound(arrFileName)
'从第一行开始写
 xlSheet.Cells(k, 1) = arrFileName(i)
 k = k + 1
Next

'选择第一行第二列开始写行数
s = 1
For j = 1 To UBound(arrFileRow)
'从第一行开始写
 xlSheet.Cells(s, 2) = arrFileRow(j)
 s = s + 1
Next

Application.DisplayAlerts = False
xlBook.SaveAs "File info" '默认保存在我的文档里面名为File info
xlBook.Close
Application.DisplayAlerts = True
Set xlBook = Nothing
Set fso = Nothing
 
 
End Sub

chen7806

QUOTE:

以下是引用GoTop在2008-9-24 17:51:00的发言：

你好，我已经把样表上传了，请帮忙看一下，谢谢了~~~

'P文件路径自己修改一下

Sub jjj()
    p = "C:\Documents and Settings\Administrator\桌面\新建文件夹\"
    n = "*.xls"
    r = 2
    Application.ScreenUpdating = False
    Range("a1:b1") = Array("已使用行数", "文件名")
    fm = Dir(p & n)
    Do While fm > ""
        Workbooks.Open (p & fm)
        Cells(r, 1) = ActiveWorkbook.Sheets(1).Range("a1").CurrentRegion.Rows.Count
        Cells(r, 2) = fm
        ActiveWorkbook.Close False
        r = r + 1
        fm = Dir()
    Loop
End Sub

GoTop

QUOTE:

以下是引用vinsine在2008-9-25 0:08:00的发言：

Sub Test()
 Dim fso As New FileSystemObject
 Dim fFile As Object
 Dim strFileName As String
 Dim strFile As String
 Dim intRow As Integer
 Dim fromPath As String

 Dim xlBook As New Excel.Workbook
 Dim xlSheet As New Excel.Worksheet
 
 fromPath = "C:\NewHTV" '指定文件夹

 If Right(fromPath, 1) <> "\" Then fromPath = fromPath & "\"
 
 
 
 
    For Each fFile In fso.GetFolder(fromPath).Files
    If UCase(Right(fFile.Name, 3)) = "XLS" Then
     strFileName = fFile.Name
     Set xlBook = Workbooks.Open(fromPath & fFile.Name)
     Set xlSheet = xlBook.Sheets(1)
     intRow = xlSheet.UsedRange.Rows.Count
     'strFileInfo = strFileName & "包含" & intRow & "行"
     strFileInfo = strFileInfo & "'" & strFileName
     strFileRow = strFileRow & "'" & intRow
     xlBook.Close
     Set xlBook = Nothing
    End If
     Next
    
'MsgBox strFile
arrFileName = Split(strFileInfo, "'")
arrFileRow = Split(strFileRow, "'")

Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)

'选择第一行第一列开始写写文件名
k = 1
For i = 1 To UBound(arrFileName)
'从第一行开始写
 xlSheet.Cells(k, 1) = arrFileName(i)
 k = k + 1
Next

'选择第一行第二列开始写行数
s = 1
For j = 1 To UBound(arrFileRow)
'从第一行开始写
 xlSheet.Cells(s, 2) = arrFileRow(j)
 s = s + 1
Next

Application.DisplayAlerts = False
xlBook.SaveAs "File info" '默认保存在我的文档里面名为File info
xlBook.Close
Application.DisplayAlerts = True
Set xlBook = Nothing
Set fso = Nothing
 
 
End Sub

你好，不知道为什么，我运行的这段代码后并没有出现结果呢

GoTop

QUOTE:

以下是引用chen7806在2008-9-25 1:11:00的发言：

'P文件路径自己修改一下

Sub jjj()
    p = "C:\Documents and Settings\Administrator\桌面\新建文件夹\"
    n = "*.xls"
    r = 2
    Application.ScreenUpdating = False
    Range("a1:b1") = Array("已使用行数", "文件名")
    fm = Dir(p & n)
    Do While fm > ""
        Workbooks.Open (p & fm)
        Cells(r, 1) = ActiveWorkbook.Sheets(1).Range("a1").CurrentRegion.Rows.Count
        Cells(r, 2) = fm
        ActiveWorkbook.Close False
        r = r + 1
        fm = Dir()
    Loop
End Sub

你好，我运行这段代码后只出现了以下标题，但是没有得到文件名和行数

已使用行数

文件名

vinsine

QUOTE:

以下是引用GoTop在2008-9-25 9:01:00的发言：

你好，不知道为什么，我运行的这段代码后并没有出现结果呢

请看代码注释 Application.DisplayAlerts = False
xlBook.SaveAs "File info" '默认保存在我的文档里面名为File info
xlBook.Close
Application.DisplayAlerts = True
Set xlBook = Nothing
Set fso = Nothing

到 我的文档 去找名为 File info 的excel文件，打开即是

northwolves

QUOTE:

以下是引用GoTop在2008-9-24 20:22:00的发言：

版主，我运行你的代码后出现错误提示

哪句出错?

GoTop

QUOTE:

以下是引用vinsine在2008-9-25 9:22:00的发言：

请看代码注释 Application.DisplayAlerts = False
xlBook.SaveAs "File info" '默认保存在我的文档里面名为File info
xlBook.Close
Application.DisplayAlerts = True
Set xlBook = Nothing
Set fso = Nothing

到 我的文档 去找名为 File info 的excel文件，打开即是

恩恩，我以前没理解这行注释

代码确实能用~~

真是太感谢了~~~~

[em17][em17][em17][em17]