使用VBA合并多个EXCEL文件到一个EXCEL文件

本文介绍了一种使用VBA脚本批量合并多个Excel文件的方法。该脚本能够递归地搜索指定文件夹及其子文件夹中的所有Excel文件,并将这些文件的数据合并到一个新的Excel工作表中。

摘要生成于 C知道 ,由 DeepSeek-R1 满血版支持, 前往体验 >



有时候我们需要把一大堆的Excel文件合并一个文件,这时候我们可以想到利用VBA来做。

这涉及到遍历文件夹以及子文件夹,找出所有的文件,并且读取文件把它们的内容合并到同一个Excel文件中去。

下面的代码可以实现这样的操作。


Sub MergeData()

    Dim strFileName As String
    Dim strFolder As String
    Dim row As Integer
    Dim col As Integer
    Dim outRow As Integer
    Dim fob As Object
    Dim fFile As file
    Set fso = CreateObject("scripting.filesystemobject")
    '中间变量worksheet
    Dim wsTemp As Worksheet
    '中间变量workbook

    Dim wbTemp As Workbook
    Dim strMergedFilePath As String
    Dim wbMerged As Workbook
    '输出用worksheet变量

    Dim wsMerged As Worksheet
    '输出用地区名
    Dim strOutFolderName As String
    '输出用城市名
    Dim strOutFileName As String
   
    Application.Visible = False
    Application.ScreenUpdating = False
   
    strMergedFilePath = ThisWorkbook.Path & "\"
   
    Set wsMerged = ThisWorkbook.Sheets(2)
   
    wsMerged.Name = "test"
       
    strFolder = Cells(2, 3).Value
   
    If Dir(strFolder, 16) = Empty Then
        MsgBox "Folder not exits!", vbOKOnly
    End If
   
    Dim file() As String
    Dim f As String
    Dim i, k
    i = 2
    k = 1

    ReDim file(1 To 1)

    '获取所有的子文件夹
    f = Dir(strFolder & "\", vbDirectory)
    Do Until f = ""
        If InStr(f, ".") = 0 Then
            k = k + 1
            ReDim Preserve file(1 To k)
            file(k) = f
        End If
        f = Dir
    Loop
   
    On Error Resume Next
   
    outRow = 3
   
    Do While i <= k
   
        strOutFolderName = file(i)
   
        strFileName = Dir(strFolder & "\" & file(i) & "\*.xlsx", vbDirectory)
       
        Do While strFileName <> ""
       
           strOutFileName = strFileName
           Set wbTemp = Workbooks.Open(strFolder & "\" & file(i) & "\" & strFileName)
                 
           Set wsTemp = wbTemp.Sheets("test")
          
          
           If wsTemp Is Nothing Then
           Else
          
            If outRow = 3 Then
                row = 2
            Else
                row = 3
            End If
           
           
            Do While wsTemp.Cells(row, 1).Value <> ""
               
                If outRow = 3 Then
                    wsMerged.Cells(outRow, 1).Value = "地区"
                    wsMerged.Cells(outRow, 2).Value = "城市"
                Else
                    wsMerged.Cells(outRow, 1).Value = strOutFolderName
                    wsMerged.Cells(outRow, 2).Value = strOutFileName
                End If
                   
                col = 1
               
                Do While wsTemp.Cells(row, col).Value <> ""
               
                   
                    wsMerged.Cells(outRow, col + 2).Value = wsTemp.Cells(row, col).Value
               
                    col = col + 1
                   
                Loop

                row = row + 1
               
                outRow = outRow + 1
               
            Loop
           
           End If
       
           wbTemp.Close
           strFileName = Dir
       
        Loop
       
        i = i + 1
      
    Loop
   
    wsMerged.Activate
    'wbMerged.SaveAs (strMergedFilePath & "MergedData.xlsx")
    Application.Visible = True

End Sub


评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值