1.新建一个excel表格。并创建两个Sheet，名字分别命名为FileList 和 All information。

2.按ALT+F11进入  VBA编程模块，插入模块。 

3.将如下 第五部分代码复制到模块中。  点击运行即可，然后就能提取指定目录下的所有excel文件信息并合并到一起输出到“All information” 中。

4.运行过程中，在弹窗中输入 想要提取信息的路径地址。

5.说明

这个脚本的逻辑分为两部分：

• 首先是提取文件夹中所有文件的基本信息，并将其填充到"FileList"工作表中。
• 之后，它将这些文件打开并将它们的内容合并到"All information"工作表中。

Sub CombinedScript()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseOn Error Resume Next' Step 1: Extracting files from foldersDim arr(1 To 10000) As StringDim arr1(1 To 100000, 1 To 6) As StringDim fso As Object, myfile As ObjectDim f, i, k, f2, f3, xDim q As Integerarr(1) = Application.InputBox("Please enter the path to scan") & "\"i = 1k = 1Do While i < UBound(arr)If arr(i) = "" Then Exit Dof = Dir(arr(i), vbDirectory)DoIf InStr(f, ".") = 0 And f <> "" Thenk = k + 1arr(k) = arr(i) & f & "\"End Iff = DirLoop Until f = ""i = i + 1Loop' Extract files informationSet fso = CreateObject("Scripting.FileSystemObject")For x = 1 To UBound(arr)If arr(x) = "" Then Exit Forf3 = Dir(arr(x) & "*.*")Do While f3 <> ""If InStr(f3, ".") > 0 Thenq = q + 1arr1(q, 5) = arr(x) & f3Set myfile = fso.GetFile(arr1(q, 5))arr1(q, 1) = f3arr1(q, 2) = myfile.Sizearr1(q, 3) = myfile.DateCreatedarr1(q, 4) = myfile.DateLastModifiedarr1(q, 6) = myfile.DateLastAccessedEnd Iff3 = DirLoopNext xSheets("FileList").Range("A2").Resize(1000, 6).ClearContentsSheets("FileList").Range("A2").Resize(q, 6) = arr1' Step 2: Combine information into "All information" sheetIf Sheets("All information").FilterMode = True ThenSheets("All information").ShowAllDataEnd IfSheets("All information").Range("A2:ZZ100000").ClearContentsDim currentFile As ObjectDim targetRow As IntegerDim temRowCount As IntegertargetRow = 2For fileCount = 2 To Sheets("FileList").Cells(10000, 1).End(xlUp).RowSet currentFile = Application.Workbooks.Open(Sheets("FileList").Cells(fileCount, 5))For sheetscount = 1 To currentFile.Sheets.CounttemRowCount = currentFile.Sheets(sheetscount).UsedRange.Rows.Count' Copy contentcurrentFile.Sheets(sheetscount).UsedRange.CopyThisWorkbook.Sheets("All information").Cells(targetRow, 3).PasteSpecial (xlPasteValues)' Set sheet and workbook informationThisWorkbook.Sheets("All information").Range("A" & targetRow & ":A" & targetRow + temRowCount).Value = currentFile.NameThisWorkbook.Sheets("All information").Range("B" & targetRow & ":B" & targetRow + temRowCount).Value = currentFile.Sheets(sheetscount).NametargetRow = targetRow + temRowCountNext sheetscountcurrentFile.Close FalseNext fileCountApplication.DisplayAlerts = TrueApplication.ScreenUpdating = True
End Sub