用VBA提取路径下所有工作簿的工作表名（四个方法）
方法一：Open方法
思路：遍历路径下的工作簿并用Workbooks.Open打开，再遍历工作表名
Workbooks.Open
打开一个工作簿。
语法表达式.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)表达式   一个代表 Workbooks 对象的变量。
1.Sub Open法()
2.Dim arr
3.Dim n&, i&, j&, s$
4.Dim wb As Workbook, sht As Worksheet, wbk As Workbook
5.Dim myPath$, myFile$
6.Application.ScreenUpdating = False   '禁刷新
7.Application.Calculation = xlManual   '禁计算
8.Set wbk = ThisWorkbook
9.myPath = ThisWorkbook.Path & "\"
10.myFile = Dir(myPath & "*.xls")
11.n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1    '计算文件个数，减1不包括自身
12.ReDim arr(1 To 1000, 1 To n)
13.Do While myFile <> ""
resize函数vba
14.If myFile <> wbk.Name Then
15.j = j + 1
16.i = 1
17.arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1)  '去后辍
18.Set wb = Workbooks.Open(myPath & "\" & myFile)      '打开工作簿
19.For Each sht In wb.Sheets   '遍历工作表
20.i = i + 1
21.arr(i, j) = sht.Name
22.Next
23.wb.Close
24.End If
25.myFile = Dir
26.Loop
27.wbk.ActiveSheet.Range("A1").Resize(i, j) = arr    '输出
28.
29.Application.Calculation = xlAutomatic   '刷新
30.Application.ScreenUpdating = True      '自动计算
31.End Sub
复制代码
方法二：GetObject方法
思路：遍历路径下的工作簿并使用 GetObject 函数访问文件，再获取工作表名
GetObject
返回文件中的 ActiveX 对象的引用。
语法
GetObject([pathname] [, class])
1.Sub GetObject法()
2.Dim cat As Object, MyTable As Object
3.Dim n&, i&, j&, s$
4.Dim myPath$, myFile$
5.Application.ScreenUpdating = False   '禁刷新
6.myPath = ThisWorkbook.Path & "\"
7.myFile = Dir(myPath & "*.xls")
8.n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1    '计算文件个数，减1不包括自身
9.ReDim arr(1 To 1000, 1 To n)
10.
11.Do While myFile <> ""
12.If myFile <> ThisWorkbook.Name Then  '不等于本工作簿执行
13.j = j + 1
14.i = 1
15.arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1)    '去后辍
16.
17.With GetObject(myPath & myFile)  '使用 GetObject 函数可以访问文件
18.For i = 1 To .Worksheets.Count    '遍历文件的工作表数
19.arr(i + 1, j) = .Worksheets(i).Name
20.Next
21.End With
22.GetObject(myPath & myFile).Close '关闭
23.End If
24.
25.myFile = Dir
26.Loop
27.Application.ScreenUpdating = True      '自动计算
28.Range("A1").Resize(i, j) = arr    '输出
29.End Sub
30.
复制代码
方法三：OpenSchema 方法
思路：遍历路径下的工作簿并使用ADO访问文件，再用OpenSchema 获取工作表名
PS：使用ADO查询大量工作簿速度较快，但ADO对字段、数据类型等要求较严格，而且ADO取得的工作表名与工作表真实的排序没有关系
OpenSchema 方法
从提供者获取数据库模式信息。
语法
Set recordset = connection.OpenSchema (QueryType, Criteria, SchemaID)
querytype 所要运行的模式查询类型 
Set recordset = connection.OpenSchema (adSchemaTables)   创建数据表记录集
1.Sub OpenSchema法()
2.Dim arr, n&, i&, j&, s$
3.Dim myPath$, myFile$
4.Dim cnn As Object, rs As Object
5.
6.myPath = ThisWorkbook.Path & "\"
7.myFile = Dir(myPath & "*.xls")
8.n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1    '计算文件个数，减1不包括自身
9.ReDim arr(1 To 1000, 1 To n)  '定义arr,最大工作表数1000
10.Do While myFile <> ""
11.If myFile <> ThisWorkbook.Name Then  '不等于本工作簿执行
12.j = j + 1
13.i = 1
14.arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1)    '去后辍
15.Set cnn = CreateObject("ADODB.Connection")
16.cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
17.Set rs = cnn.OpenSchema(20)   'Set rs = cnn.OpenSchema(adSchemaTables)，创建数据表记录集
18.Do Until rs.EOF
19.If rs.Fields("TABLE_TYPE") = "TABLE" Then
20.i = i + 1
21.s = Replace(rs("TABLE_NAME").Value, "'", "")              '去除"’"(数字工作表）
22.If Right(s, 1) = "$"  Then arr(i, j) = Left(s, Len(s) - 1)    '去除$号
23.End If
24.rs.MoveNext
25.Loop
26.End If
27.myFile = Dir
28.Loop
29.rs.Close
30.cnn.Close

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。