【VBA】获取指定目录下的Excel文件，并合并所有excel中的内容。

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

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

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

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

5.说明

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

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

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