合并多个格式相同XLS的方法

        作者:黄启清
        日期:08-3-17
        说明:可以将当前XLS宏运行所在目录的所有XLS全部合并到一个XLS文件里面
        Dim curBook     As Workbook
        Dim curSheet     As Worksheet
        Dim row     As Integer
        Dim strPath As String
        Dim strResultFile As String
        Dim bIsFirst As Boolean
       
       
        Application.DisplayAlerts = False '取消警告信息
        Application.ScreenUpdating = False '禁止屏幕刷新
        bIsFirst = False
        On Error GoTo ErrMsg
       
      '  strResultFile = InputBox("请输入你合并后的文件名称,不用输入扩展名!", "提醒", "ALL-XLS")
       
       ' If strResultFile = "" Then
       
        '    MsgBox "你已经取消了此次的操作!", vbInformation
         '   Exit Sub
       
        'End If
       
       
        strResultFile = "ALL-XLS" & ".XLS"
       
       
       
        Set curBook = Workbooks.Add
       
        If Dir(ThisWorkbook.Path & "\" & strResultFile) <> "" Then
       
            If MsgBox("文件""" & strResultFile & """已经存在,你确认覆盖?!", vbYesNo + vbInformation, "提示") <> vbYes Then
                curBook.Close
                Exit Sub
            End If
            Kill ThisWorkbook.Path & "\" & strResultFile
           
        End If
       
        curBook.SaveAs ThisWorkbook.Path & "\" & strResultFile
       
        Set curBook = Workbooks(strResultFile)
        Set curSheet = curBook.Sheets(1)
        row = 1
        strPath = UCase(Dir(ThisWorkbook.Path & "\*.xls"))
       
        While strPath <> ""
       
                If strPath <> strResultFile And strPath <> UCase(ThisWorkbook.Name) Then
               
                        strPath = ThisWorkbook.Path & "\" & strPath
                        Dim book     As Workbook
                        Dim sheet     As Worksheet
                        Set book = Workbooks.Open(strPath)
                        Set sheet = book.Sheets(1)
                        book.Activate
                        Set sheet = ActiveSheet
                       
                        sheet.Range("A1:B1 ").CurrentRegion.Select
                        Dim curRow     As Integer
                        '有效区域
                       
                        curRow = row + sheet.Range("A65536").End(xlUp).row + 1
                       
                        'curRow = row + sheet.Range("A1:B1 ").CurrentRegion.Count
                        'curRow = row + sheet.UsedRange.Count
                       
                      
                        Selection.Copy
                        curBook.Activate
                        'MsgBox "currow:" & curRow & " row:" & row
                       
                       
                        curBook.Sheets(1).Range("A" & row).Select
                        curBook.Sheets(1).Paste
                        '按每一个Excel的有效区域进行Copy,并Paste到目标Excel文档
                       
                       If row > 1 Then
                            curBook.Sheets(1).Rows(row).Delete '只保留第一个标题部分,删除重复的标题部分
                            bIsFirst = True
                       End If
                      
                                             
                       If Not bIsFirst Then
                      
                            row = curRow - 1
                           
                        Else
                       
                            row = curRow - 2
                           
                        End If
                       
                       
                        book.Close False
                       
                End If
                strPath = UCase(Dir)
        Wend
       
        MsgBox "合并成功,请查看" & strResultFile & "文档"
        curBook.Save
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
       
        Exit Sub
       
ErrMsg:

        If InStr(Err.Description, "权限") > 0 Then
       
            MsgBox "VBA在执行过程中发生错误，错误信息如下：" & vbCrLf & vbCrLf & _
            "错误来源：" & Err.Source & vbCrLf & _
            "错误号码：" & Err.Number & vbCrLf & _
            "错误信息：" & Err.Description & vbCrLf & _
            "建议方案：请将打开的" & strResultFile & "文件关闭后再重试", vbExclamation
           
        Else
            MsgBox "VBA在执行过程中发生错误，错误信息如下：" & vbCrLf & vbCrLf & _
            "错误来源：" & Err.Source & vbCrLf & _
            "错误号码：" & Err.Number & vbCrLf & _
            "错误信息：" & Err.Description & vbCrLf, vbExclamation
           
        End If
           
        If Not (curBook Is Nothing) Then curBook.Close
'