【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开发易登软件3 天前
【vba源码】导入excel批注信息
数据库·excel·vba·access
ruleslol10 天前
VBA10-处理Excel的动态数据区域
excel·vba
lc寒曦13 天前
【VBA实战】用Excel制作排序算法动画续
排序算法·excel·vba·文档自动化处理
ruleslol14 天前
VBA02-初识宏——EXCEL录像机
excel·vba
lc寒曦15 天前
【VBA实战】用Excel制作排序算法动画
排序算法·excel·vba
szial18 天前
使用VBA宏合并多个Excel文件的Sheet页
excel·vba
taller_20002 个月前
使用VBA快速将文本转换为Word表格
word·vba·表格·word vba·文本转表格
arvinzd2 个月前
VBA解除Excel工作表保护
excel·vba
maizeman1262 个月前
excel VBA进行间比法设计
excel·vba·间比法·品比试验
oennn欧冷2 个月前
中文关键字检索分析-导出到csv或者excel-多文件或文件夹-使用python和asyncio和pandas的dataframe
python·pandas·vba·asyncio·dataframe·completablefuture