vb获取文件夹下几百个excel的所有sheet名称效率问题

[usbusb2007]

文件夹下有几百个excel，每个都有不同个数的sheet，怎么才能获取所有的sheet名称呢，形式最好是excel+sheet,我现在采用的是
先获取所有excel的名称（这个很快），然后循环所有的excel分别执行下面的代码
Dim XlApp As New Excel.Application
Dim XLWorkBook As New Excel.Workbook
Set XLWorkBook = XlApp.Workbooks.Open(App.Path & "\1.xls")
For i = 1 To XLWorkBook.Worksheets.Count
List1.AddItem XLWorkBook.Sheets(i).Name
Next i
XlApp.Quit
这段代码实际上还是先把excel打开，取完sheet名称后再关闭， 问题出来了，几百个excel要执行两三分钟以上，这肯定是不行的，请问大家有没有什么更快的方法，能取到文件夹下所有excel的所有sheet名称。
谢谢

[赵4老师]

试试看：

 Dim XlApp As New Excel.Application
 Dim XLWorkBook As New Excel.Workbook
Dim fn as String
Dim n As Long
    XlApp.Visible=False
  for n=1 to 100
    fn=App.Path & "\"+CStr(n)+".xls"
    Set XLWorkBook = XlApp.Workbooks.Open(fn)
    For each in XLWorkBook.Worksheet in XLWorkBook.Sheets
        debug.print fn;"+";XLWorkBook.Sheet.Name
    Next
    Set XLWorkBook=Nothing
    XlApp.Close
next n

[赵4老师]

For each in XLWorkBook.Worksheet in XLWorkBook.Sheets 应改为 For each XLWorkBook.Worksheet in XLWorkBook.Sheets

[usbusb2007]

楼上的方法也是打开再关闭，肯定快不了

[赵4老师]

引用 10 楼 usbusb2007 的回复:

楼上的方法也是打开再关闭，肯定快不了

XlApp.Visible=False‘关闭Excel显示以加速 for each比for快。 你确定？ 不要迷信书、考题、老师、回帖； 要迷信CPU、编译器、调试器、运行结果。 并请结合“盲人摸太阳”和“驾船出海时一定只带一个指南针。”加以理解。 任何理论、权威、传说、真理、标准、解释、想象、知识……都比不上摆在眼前的事实！ 有人说一套做一套，你相信他说的还是相信他做的？ 其实严格来说这个世界上古往今来所有人都是说一套做一套，不是吗？ 不要写连自己也预测不了结果的代码！

[赵4老师]

引用 10 楼 usbusb2007 的回复:

楼上的方法也是打开再关闭，肯定快不了

Debug.Print比List1.AddItem快

[usbusb2007]

关键是我不光要把结果打印出来。我还要在下面的代码中用到这个结果啊，只能把结果先放到list中

[usbusb2007]

代码不是慢在for 或for each ，而是慢在打开和关闭excel上，只要有打开关闭的动作，都快不了

[熊孩子开学喽]

引用 14 楼 usbusb2007 的回复:

代码不是慢在for 或for each ，而是慢在打开和关闭excel上，只要有打开关闭的动作，都快不了

快下班了, 来不及多说. 上次我做了一个扫描移除EXCEL宏病毒的东西, http://download.csdn.net/detail/wallescai/4349826 你打开看看吧, 应该是每个excelapp对象打开关闭一定数量的excel文件之后最好要删除对象重新来一个. 应该是涉及到临时文件和excel本身的缓存等一些东西. 我没有深究, 只是这样用. 当时测试的结果是当app对象连续操作几十个excel文件之后(即使每次都关闭excel文件), 反应就会越来越慢, 直到龟速. 所以对策就是开几次之后重新建立对象. 微软的东西不就是这样的么, 电脑慢了重启呗, 呵呵

[usbusb2007]

客户要求这样实现，大家帮帮忙啊

[of123]

Option Explicit

Private Sub Command1_Click()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, strFile As String

Set cn = New ADODB.Connection

strFile = Dir("c:\test\*.xls")
Do While strFile > ""

    Debug.Print strFile & ":"
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\test\" & strFile & ";Extended Properties=""Excel 8.0; HDR=Yes;IMEX=1"""
    
    Set rs = cn.OpenSchema(adSchemaTables)
    
    Do Until rs.EOF
        If rs!Table_Type = "TABLE" Then Debug.Print vbTab & rs!Table_Name
        rs.MoveNext
    Loop
    
    cn.Close
    strFile = Dir()
Loop
Set rs = Nothing
Set cn = Nothing
End Sub

结果

新建 Microsoft Excel 工作表.xls:
    Sheet1$
    Sheet2$
    Sheet3$
test.xls:
    工作表1$
    工作表2$
    工作表3$

[赵4老师]

引用 13 楼 usbusb2007 的回复:

关键是我不光要把结果打印出来。我还要在下面的代码中用到这个结果啊，只能把结果先放到list中

你不会放在一个字符串数组中吗？

Const MAXN As Long=1000
Dim strarray(0 TO MAXN) as String

[of123]

放到不定长字符串数组也未必很快，会不断重新分配内存。如果 ListBox 设置 Visible = False，应该效果差不多。

[usbusb2007]

楼上说的对，我就是放到一个不定长数组中的，很慢

[of123]

自己打个断点跟踪一下，看是什么问题。

[usbusb2007]

请问楼上，我新建的excel就一切正常，但是以前的excel提取时都多了这个sheet “UFPrn20130410154801”， 还有我要是excel2013（后缀为.xlsx）该怎么修改呢，谢谢

[of123]

如果两种扩展名的文件都要查找，把代码中间部分复制成两份，其中一份改为： strFile = Dir("c:\test\*.xlsx") ......

[usbusb2007]

为什么我执行楼上的结果是这样的，打印了3遍，而且多了个没有的sheet “UFPrn20130410154801” 新建 Microsoft Excel 工作表.xls: UFPrn20130410154801 Sheet1$ Sheet2$ Sheet3$ 新建 Microsoft Excel 工作表.xls: UFPrn20130410154801 Sheet1$ Sheet2$ Sheet3$ 新建 Microsoft Excel 工作表.xls: UFPrn20130410154801 Sheet1$ Sheet2$ Sheet3$

[usbusb2007]

使用xlsx的话，这句话报错 cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\test\" & strFile & ";Extended Properties=""Excel 8.0; HDR=Yes;IMEX=1"""

[of123]

是 OLEDB.4.0 不支持 xlsx。需要更换 Provider： cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\test\" & strFile & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""

[MMICE]

学习了。。