1.新建一个excel表格。并创建两个Sheet,名字分别命名为FileList 和 All information。
2.按ALT+F11进入 VBA编程模块,插入模块。
3.将如下 第五部分代码复制到模块中。 点击运行即可,然后就能提取指定目录下的所有excel文件信息并合并到一起输出到"All information" 中。
4.运行过程中,在弹窗中输入 想要提取信息的路径地址。
5.说明
这个脚本的逻辑分为两部分:
- 首先是提取文件夹中所有文件的基本信息,并将其填充到"FileList"工作表中。
- 之后,它将这些文件打开并将它们的内容合并到"All information"工作表中。
vbnet
Sub CombinedScript()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
' Step 1: Extracting files from folders
Dim arr(1 To 10000) As String
Dim arr1(1 To 100000, 1 To 6) As String
Dim fso As Object, myfile As Object
Dim f, i, k, f2, f3, x
Dim q As Integer
arr(1) = Application.InputBox("Please enter the path to scan") & "\"
i = 1
k = 1
Do While i < UBound(arr)
If arr(i) = "" Then Exit Do
f = Dir(arr(i), vbDirectory)
Do
If InStr(f, ".") = 0 And f <> "" Then
k = k + 1
arr(k) = arr(i) & f & "\"
End If
f = Dir
Loop Until f = ""
i = i + 1
Loop
' Extract files information
Set fso = CreateObject("Scripting.FileSystemObject")
For x = 1 To UBound(arr)
If arr(x) = "" Then Exit For
f3 = Dir(arr(x) & "*.*")
Do While f3 <> ""
If InStr(f3, ".") > 0 Then
q = q + 1
arr1(q, 5) = arr(x) & f3
Set myfile = fso.GetFile(arr1(q, 5))
arr1(q, 1) = f3
arr1(q, 2) = myfile.Size
arr1(q, 3) = myfile.DateCreated
arr1(q, 4) = myfile.DateLastModified
arr1(q, 6) = myfile.DateLastAccessed
End If
f3 = Dir
Loop
Next x
Sheets("FileList").Range("A2").Resize(1000, 6).ClearContents
Sheets("FileList").Range("A2").Resize(q, 6) = arr1
' Step 2: Combine information into "All information" sheet
If Sheets("All information").FilterMode = True Then
Sheets("All information").ShowAllData
End If
Sheets("All information").Range("A2:ZZ100000").ClearContents
Dim currentFile As Object
Dim targetRow As Integer
Dim temRowCount As Integer
targetRow = 2
For fileCount = 2 To Sheets("FileList").Cells(10000, 1).End(xlUp).Row
Set currentFile = Application.Workbooks.Open(Sheets("FileList").Cells(fileCount, 5))
For sheetscount = 1 To currentFile.Sheets.Count
temRowCount = currentFile.Sheets(sheetscount).UsedRange.Rows.Count
' Copy content
currentFile.Sheets(sheetscount).UsedRange.Copy
ThisWorkbook.Sheets("All information").Cells(targetRow, 3).PasteSpecial (xlPasteValues)
' Set sheet and workbook information
ThisWorkbook.Sheets("All information").Range("A" & targetRow & ":A" & targetRow + temRowCount).Value = currentFile.Name
ThisWorkbook.Sheets("All information").Range("B" & targetRow & ":B" & targetRow + temRowCount).Value = currentFile.Sheets(sheetscount).Name
targetRow = targetRow + temRowCount
Next sheetscount
currentFile.Close False
Next fileCount
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub