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

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
相关推荐
Access开发易登软件2 天前
Access开发导出PDF的N种姿势,你get了吗?
后端·低代码·pdf·excel·vba·access·access开发
課代表2 天前
VBA 中的 Excel 工作表函数
excel·vba·函数·对象·属性·range·静态变量
Lilixxs2 天前
VBA 中使用 ADODB 操作 SQLite 插入中文乱码问题
数据库·中间件·sqlite·乱码·vba·odbc·adodb
只会HelloWorld的华娃15 天前
VBA模板记录
microsoft·vba
Access开发易登软件1 个月前
Access开发右下角浮窗提醒
microsoft·vba·access·access开发
Access开发易登软件1 个月前
Access开发一键删除Excel指定工作表
服务器·前端·后端·excel·vba·access·access开发
Prodigy_kyw2 个月前
VBA初学3----实战(VBA实现Excel转csv)
excel·vba·csv
yivifu3 个月前
利用VBA将Word文档修改为符合EPUB3标准规范的HTML文件
word·vba·epub
Learn-Share_HY3 个月前
[Excel VBA]如何製作買三送一優惠條件的POS結帳介面?
excel·vba·office·自動化·自動化辦公
shandianchengzi3 个月前
【工具】Quicker/VBA|PPT 在指定位置添加有颜色的参考线
powerpoint·vba·ppt·quicker