用VBA提取路径下所有工作簿的工作表名(四个方法)

1、用VBA提取路径下所有工作簿的工作表名（四个方法） 方法一：Open方法思路：遍历路径下的工作簿并用Workbooks.Open打开，再遍历工作表名Workbooks.Open打开一个工作簿。语法表达式.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)表达式 一个代表 Workbooks 对

2、象的变量。Sub Open法() Dim arr Dim n&, i&, j&, s$ Dim wb As Workbook, sht As Worksheet, wbk As Workbook Dim myPath$, myFile$ Application.ScreenUpdating = False '禁刷新 Application.Calculation = xlManual '禁计算 Set wbk = ThisWorkbook myPath = ThisWorkbook.Path & "&qu

3、ot; myFile = Dir(myPath & "*.xls") n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1 '计算文件个数，减1不包括自身 ReDim arr(1 To 1000, 1 To n) Do While myFile <> "" If myFile <> wbk.Name Then j = j + 1 i = 1 arr(

4、1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后辍 Set wb = Workbooks.Open(myPath & "" & myFile) '打开工作簿 For Each sht In wb.Sheets '遍历工作表 i = i + 1 arr(i, j) = sht.Name Next wb.Close End If myFile = Dir Loop wbk.ActiveSheet.Range("A1").Resiz

5、e(i, j) = arr '输出 Application.Calculation = xlAutomatic '刷新 Application.ScreenUpdating = True '自动计算End Sub复制代码方法二：GetObject方法思路：遍历路径下的工作簿并使用 GetObject 函数访问文件，再获取工作表名GetObject返回文件中的 ActiveX 对象的引用。语法GetObject(pathname , class)Sub GetObject法() Dim cat As Object, MyTable As Object Dim n&

6、amp;, i&, j&, s$ Dim myPath$, myFile$ Application.ScreenUpdating = False '禁刷新 myPath = ThisWorkbook.Path & "" myFile = Dir(myPath & "*.xls") n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1 '计算文件个数，

7、减1不包括自身 ReDim arr(1 To 1000, 1 To n) Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿执行 j = j + 1 i = 1 arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后辍 With GetObject(myPath & myFile) '使用 GetObject 函数可以访问文

8、件 For i = 1 To .Worksheets.Count '遍历文件的工作表数 arr(i + 1, j) = .Worksheets(i).Name Next End With GetObject(myPath & myFile).Close '关闭 End If myFile = Dir Loop Application.ScreenUpdating = True '自动计算 Range("A1").Resize(i, j) = arr '输出End Sub复制代码方法三：OpenSchema 方法思路：遍历路径下

9、的工作簿并使用ADO访问文件，再用OpenSchema 获取工作表名PS：使用ADO查询大量工作簿速度较快，但ADO对字段、数据类型等要求较严格，而且ADO取得的工作表名与工作表真实的排序没有关系OpenSchema 方法从提供者获取数据库模式信息。语法Set recordset = connection.OpenSchema (QueryType, Criteria, SchemaID)querytype 所要运行的模式查询类型 Set recordset = connection.OpenSchema (adSchemaTables) 创建数据表记录集Sub OpenSchema法() D

10、im arr, n&, i&, j&, s$ Dim myPath$, myFile$ Dim cnn As Object, rs As Object myPath = ThisWorkbook.Path & "" myFile = Dir(myPath & "*.xls") n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1 '计算文件个

11、数，减1不包括自身 ReDim arr(1 To 1000, 1 To n) '定义arr,最大工作表数1000 Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿执行 j = j + 1 i = 1 arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后辍 Set cnn = CreateObject("ADODB.Connec

12、tion") cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile Set rs = cnn.OpenSchema(20) 'Set rs = cnn.OpenSchema(adSchemaTables)，创建数据表记录集 Do Until rs.EOF If rs.Fields("TABLE_TYPE") = "TABLE"

13、Then i = i + 1 s = Replace(rs("TABLE_NAME").Value, "'", "") '去除""(数字工作表） If Right(s, 1) = "$" Then arr(i, j) = Left(s, Len(s) - 1) '去除$号 End If rs.MoveNext Loop End If myFile = Dir Loop rs.Close cnn.Close Set rs = Nothing Set cnn = Nothin

14、g Range("A1").Resize(i, j) = arr '输出End Sub复制代码方法四：ADOX.Catalog 方法思路：遍历路径下的工作簿调用的是ADOX.Catalog组件访问文件，再遍历对象Table 获取工作表名 For Each MyTable In TablesADOX.CatalogMicrosoft? ActiveX? Data Objects Extensions for Data Definition Language and Security (ADOX) 是对 ADO 对象和编程模型的扩展。ADOX 包括用于模式创建和修改的对

15、象，以及安全性。由于它是基于对象实现模式操作，所以用户可以编写对各种数据源都能有效运行的代码，而与它们原始语法中的差异无关。Sub ADOX法() Dim cat As Object, MyTable As Object Dim n&, i&, j&, s$ Dim myPath$, myFile$ myPath = ThisWorkbook.Path & "" myFile = Dir(myPath & "*.xls") n = CreateObject("Scr

16、ipting.FileSystemObject").GetFolder(myPath).Files.Count - 1 '计算文件个数，减1不包括自身 ReDim arr(1 To 1000, 1 To n) Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿执行 j = j + 1 i = 1 arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后辍 Set cat = CreateObject("ADOX.Catalog") cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & myPath & myFile For Each MyTable In cat.Tables If MyTable.Type = "TABLE" Then s = Repla