VBA合并Excel文件-优快云博客

本文链接：https://blog.youkuaiyun.com/BLUESKYOFCHINA/article/details/4351277

本文提供了一段使用VBA编写的代码，该代码能够帮助用户批量合并多个具有相同表头结构的Excel文件，并将合并后的数据保存到指定的工作表中。

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

合并表头结构相同的的excel

Private Sub CommandButton1_Click()
    Dim FilesToOpen
    Dim x As Integer
    Dim headRows As Integer
    Dim nName As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    nName = Worksheets.Application.ActiveWorkbook.Name

    headRows = Sheets("宏").Range("C1").Value

    FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.xls*),*.xls", MultiSelect:=True, Title:="要合并的文件")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "没有选中文件"
        GoTo ExitHandler
    End If

    Sheets("数据").Select
    Sheets("数据").Range("A1").Select
    ActiveCell.CurrentRegion.Select
    Selection.Delete Shift:=xlUp

    x = 1
    While x <= UBound(FilesToOpen)
        Dim Filename As String
        Dim eRows As Long

        Filename = FilesToOpen(x)
        Workbooks.Open Filename

        Filename = Mid(Filename, InStrRev(Filename, "/") + 1)
        Windows(Filename).Activate

        Set tbl = ActiveCell.CurrentRegion

        If x = 1 Then
            tbl.Offset(0, 0).Resize(tbl.Rows.Count, tbl.Columns.Count).Select
        Else
            tbl.Offset(headRows, 0).Resize(tbl.Rows.Count - headRows, tbl.Columns.Count).Select
        End If
        Selection.Copy

        Windows(nName).Activate
        Sheets(2).Select
        eRows = Sheets(2).UsedRange.Cells.Rows.Count + 1

        If x = 1 Then
            Sheets(2).Range("A1").Select
        Else
            Sheets(2).Range("A" + LTrim(Str(eRows))).Select
        End If

        ActiveSheet.Paste

        Application.CutCopyMode = False

        Windows(Filename).Activate

        ActiveWindow.Close False

        x = x + 1
    Wend

    ActiveWorkbook.Save

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Private Sub CommandButton2_Click()
    Dim path As String, file As String, fullfile As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    path = Worksheets.Application.ActiveWorkbook.FullName

    file = Sheets("宏").Range("D7")

    fullfile = Left(path, InStrRev(path, "/")) + Sheets("宏").Range("D7")

    Sheets("宏").Range("D11") = fullfile


    Application.Workbooks.Add.SaveAs (fullfile)

    Windows("合并Excel.xls").Activate
    Sheets("数据").Select
    Sheets("数据").Range("A1").Select
    ActiveCell.CurrentRegion.Select
    Selection.Copy

    Windows(file).Activate
    Sheets(1).Select
    Sheets(1).Range("A1").Select
    ActiveSheet.Paste

    ActiveWindow.Close True
    Application.CutCopyMode = False

    Sheets("宏").Select

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler

End Sub