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



有时候我们需要把一大堆的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