合并多个格式相同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 '

转载于:https://www.cnblogs.com/HappyQQ/archive/2008/03/17/1110280.html

相关资源：合并多个XLS文件的工作表