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

' 放置导入工作簿名称的工作表
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