用VBA提取路徑下所有工作簿的工作表名(四個(gè)方法)

1、用VBA提取路徑下所有工作簿的工作表名（四個(gè)方法） 方法一：Open方法思路：遍歷路徑下的工作簿并用Workbooks.Open打開，再遍歷工作表名Workbooks.Open打開一個(gè)工作簿。語法表達(dá)式.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)表達(dá)式 一個(gè)代表 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 '禁計(jì)算 Set wbk = ThisWorkbook myPath = ThisWorkbook.Path & "&qu

3、ot; myFile = Dir(myPath & "*.xls") n = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files.Count - 1 '計(jì)算文件個(gè)數(shù)，減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 '自動計(jì)算End Sub復(fù)制代碼方法二：GetObject方法思路：遍歷路徑下的工作簿并使用 GetObject 函數(shù)訪問文件，再獲取工作表名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 '計(jì)算文件個(gè)數(shù)，

7、減1不包括自身 ReDim arr(1 To 1000, 1 To n) Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿執(zhí)行 j = j + 1 i = 1 arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后輟 With GetObject(myPath & myFile) '使用 GetObject 函數(shù)可以訪問文

8、件 For i = 1 To .Worksheets.Count '遍歷文件的工作表數(shù) arr(i + 1, j) = .Worksheets(i).Name Next End With GetObject(myPath & myFile).Close '關(guān)閉 End If myFile = Dir Loop Application.ScreenUpdating = True '自動計(jì)算 Range("A1").Resize(i, j) = arr '輸出End Sub復(fù)制代碼方法三：OpenSchema 方法思路：遍歷路徑下

9、的工作簿并使用ADO訪問文件，再用OpenSchema 獲取工作表名PS：使用ADO查詢大量工作簿速度較快，但ADO對字段、數(shù)據(jù)類型等要求較嚴(yán)格，而且ADO取得的工作表名與工作表真實(shí)的排序沒有關(guān)系OpenSchema 方法從提供者獲取數(shù)據(jù)庫模式信息。語法Set recordset = connection.OpenSchema (QueryType, Criteria, SchemaID)querytype 所要運(yùn)行的模式查詢類型 Set recordset = connection.OpenSchema (adSchemaTables) 創(chuàng)建數(shù)據(jù)表記錄集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 '計(jì)算文件個(gè)

11、數(shù)，減1不包括自身 ReDim arr(1 To 1000, 1 To n) '定義arr,最大工作表數(shù)1000 Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿執(zhí)行 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)，創(chuàng)建數(shù)據(jù)表記錄集 Do Until rs.EOF If rs.Fields("TABLE_TYPE") = "TABLE"

13、Then i = i + 1 s = Replace(rs("TABLE_NAME").Value, "'", "") '去除""(數(shù)字工作表） 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復(fù)制代碼方法四：ADOX.Catalog 方法思路：遍歷路徑下的工作簿調(diào)用的是ADOX.Catalog組件訪問文件，再遍歷對象Table 獲取工作表名 For Each MyTable In TablesADOX.CatalogMicrosoft? ActiveX? Data Objects Extensions for Data Definition Language and Security (ADOX) 是對 ADO 對象和編程模型的擴(kuò)展。ADOX 包括用于模式創(chuàng)建和修改的對

15、象，以及安全性。由于它是基于對象實(shí)現(xiàn)模式操作，所以用戶可以編寫對各種數(shù)據(jù)源都能有效運(yùn)行的代碼，而與它們原始語法中的差異無關(guān)。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 '計(jì)算文件個(gè)數(shù)，減1不包括自身 ReDim arr(1 To 1000, 1 To n) Do While myFile <> "" If myFile <> ThisWorkbook.Name Then '不等于本工作簿執(zhí)行 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