[Excel VBA] 用VBA提取路径下所有工作簿的工作表名（四个方法）

[peng]

方法一：Open方法
思路：遍历路径下的工作簿并用Workbooks.Open打开，再遍历工作表名

Workbooks.Open
打开一个工作簿。
语法表达式.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)表达式 一个代表 Workbooks 对象的变量。

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 & ""
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(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").Resize(i, j) = arr '输出

Application.Calculation = xlAutomatic '刷新
Application.ScreenUpdating = True '自动计算
End Sub
复制代码

[peng]

方法二：GetObject方法
思路：遍历路径下的工作簿并使用 GetObject 函数访问文件，再获取工作表名

GetObject
返回文件中的 ActiveX 对象的引用。
语法
GetObject([pathname] [, class])

Sub GetObject法()
Dim cat As Object, MyTable As Object
Dim n&, 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 '计算文件个数，减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 函数可以访问文件
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

[peng]

方法三：OpenSchema 方法
思路：遍历路径下的工作簿并使用ADO访问文件，再用OpenSchema 获取工作表名
PS：使用ADO查询大量工作簿速度较快，但ADO对字段、数据类型等要求较严格，而且ADO取得的工作表名与工作表真实的排序没有关系

OpenSchema 方法
从提供者获取数据库模式信息。
语法
Set recordset = connection.OpenSchema (QueryType, Criteria, SchemaID)
querytype 所要运行的模式查询类型
Set recordset = connection.OpenSchema (adSchemaTables) 创建数据表记录集

Sub OpenSchema法()
Dim 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 '计算文件个数，减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.Connection")
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" 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 = Nothing
Range("A1").Resize(i, j) = arr '输出
End Sub

[peng]

方法四：ADOX.Catalog 方法
思路：遍历路径下的工作簿调用的是ADOX.Catalog组件访问文件，再遍历对象Table 获取工作表名 For Each MyTable In Tables

ADOX.Catalog
Microsoft&#174; ActiveX&#174; Data Objects Extensions for Data Definition Language and Security (ADOX) 是对 ADO 对象和编程模型的扩展。ADOX 包括用于模式创建和修改的对象，以及安全性。由于它是基于对象实现模式操作，所以用户可以编写对各种数据源都能有效运行的代码，而与它们原始语法中的差异无关。

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("Scripting.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 = Replace(MyTable.Name, "'", "")
If Right(s, 1) = "$" Then
i = i + 1
arr(i, j) = Left(s, Len(s) - 1)
End If
End If
Next

End If
myFile = Dir
Loop
Set cat = Nothing
Set MyTable = Nothing
Range("A1").Resize(i, j) = arr '输出
End Sub