多个excel工作簿合并_Excel应用实践10：合并多个工作簿中的数据

学习Excel技术，关注微信公众号：

excelperfect

这是ozgrid.com论坛中的一个问题贴子：

我有超过50个具有相同格式的Excel文件，它们的列标题相同，并且都放置在同一文件夹，有什么快速的方法将它们合并到一个单独的Excel文件的一个工作表中？

假设工作簿文件结构如下图1所示。

图1

其中，在文件夹“要合并的工作簿文件”中，有3个示例工作簿文件“测试1.xls、测试2.xls、测试3.xls”，将它们合并到工作簿“合并.xls”中。

在“合并.xls”工作簿中，有三个工作表。其中，“设置”工作表中的单元格B2中的数据为每个工作簿中想要合并的工作表名，这里假设每个工作簿中的工作表名相同；单元格B3为要合并的数据开始的行号。

图2

在“导入工作簿名”工作表中将放置合并的工作簿的名称。

“合并工作表”就是我们要放置合并的数据的工作表。

完整的VBA代码如下：

' 放置导入工作簿名称的工作表

Private Const importedSheet AsString = "导入工作簿名"

'放置合并数据的工作表

Private Const combinedSheet AsString = "合并工作表"

' 放置导入工作簿名称的行号

Private importPtr As Long

Sub main()

    Dim response As Variant

    response = MsgBox("想要运行合并程序吗?" & vbCr & _

        "这将擦除" & combinedSheet & "工作表中已前合并的数据", _

        vbYesNoCancel + vbDefaultButton3 +vbQuestion, "合并处理")

    If response = vbYes Then

        Call selectXls

    End If

End Sub

Private Sub selectXls()

    ' 合并数据的工作簿

    Dim thisWb As Workbook

    ' 包含工作簿完整路径和文件名的数组

    Dim xlsFiles As Variant

    ' 当前的工作簿文件路径和文件名

    Dim xls As Variant

    ' 工作簿文件中(通用的)工作表名

    Dim xlsCommonSheet As String

    ' 复制数据开始的行号

    Dim startRowCopy As Long

    ' 粘贴数据开始的行号

    Dim pastePtr As Long

    On Error GoTo genericHandler

    ' 帮助加快代码处理速度

    Application.EnableCancelKey = False

    Application.Calculation =xlCalculationManual

    xlsCommonSheet =Range("Sheet_Name_to_Combine")

    startRowCopy = Range("startRow")

    Set thisWb = Workbooks(ThisWorkbook.Name)

    xlsFiles = Application.GetOpenFilename( _

        "Micosoft Excel工作簿(*.xls*), *.xls*", , _

        "选择要合并的文件", , True)

    Application.ScreenUpdating = False

    ' 如果用户没有点击取消按钮

    If IsArray(xlsFiles) Then

        Sheets(combinedSheet).Select

        pastePtr = startRowCopy

        '重置 & 清除数据

        importPtr = 0

       thisWb.Sheets(importedSheet).Cells.Clear

       thisWb.Sheets(combinedSheet).Rows(pastePtr & ":" &Application.Rows.Count).Clear

        For Each xls In xlsFiles

            If thisWb.FullName <> xlsThen

                Call processXls(pastePtr, xls,thisWb, xlsCommonSheet, startRowCopy)

            End If

        Next xls

        MsgBox "处理成功", vbInformation + vbOKOnly,"合并程序"

    End If

    Exit Sub

genericHandler: ' 错误处理

    thisWb.Activate

    Call resetDefault

    MsgBox "错误号: " & Err.Number & vbCr & _

        "错误说明: " & _

        Err.Description, vbInformation +vbOKOnly, _

        "合并工作簿错误报告"

End Sub

Private Sub processXls(ByRefpastePtr As Long, ByVal xls As Variant, _

                       ByVal thisWb AsWorkbook, _

                       ByVal xlsCommonSheet AsString, ByVal startRowCopy As Long)

    ' 打开的工作簿对象

    Dim openWb As Workbook

    ' 工作表中最后一个数据单元格所在的行

    Dim lastRowx As Long

    ' 打开工作簿

    Workbooks.Open (xls)

    Set openWb = Workbooks(ActiveWorkbook.Name)

    With openWb.Sheets(xlsCommonSheet)

        .Select

        lastRowx = lastRow()

        If lastRowx > 0 Then

            .Rows(startRowCopy &":" & lastRow).Copy _

              thisWb.Sheets(combinedSheet).Range("A" & pastePtr)

            pastePtr = pastePtr + (lastRowx -startRowCopy) + 1

            ' 导入数据的工作簿名

            importPtr = importPtr + 1

            thisWb.Sheets(importedSheet).Range("A"& importPtr) = openWb.Name

        End If

    End With

    ' 关闭工作簿

    Workbooks(openWb.Name).CloseSaveChanges:=False

End Sub

Private Function lastRow() AsLong

    lastRow = 0

    If WorksheetFunction.CountA(Cells) > 0Then

        '按行向后搜索

        lastRow =Cells.Find(What:="*", After:=[a1], _

              SearchOrder:=xlByRows, _

              SearchDirection:=xlPrevious).Row

    End If

End Function

Private Sub resetDefault()

    ' 重置应用程序屏幕刷新和计算模式

    Application.ScreenUpdating = True

    Application.Calculation =xlCalculationAutomatic

End Sub

运行main过程，弹出如下图3所示的对话框。

图3

选择“是”按钮，弹出如下图4所示的选择文件对话框。

图4

导入到要合并的工作簿所在的文件夹，选择要合并的工作簿文件，单击“打开”按钮。如果一切顺利，则合并数据完成，并弹出如下图5所示的信息。

图5

我们可以查看结果。在“导入工作簿名”工作表中，列出了已经合并数据的工作簿名，如下图6所示。

图6

在“合并工作表”工作表中，是合并后的数据，如下图7所示。

图7

代码的图片版如下：