批量合并excel工作表

来源:互联网 发布:北航软件学院毕业生 编辑:程序博客网 时间:2024/04/30 08:14

(1)以下代码适用于并列的多个文件夹内分别含有一个excel文件的情况,且后缀名为.xlsx,其他格式可修改红色字体。
(2)工作表合并后按文件夹名称排列,所以文件夹需先按顺序重命名,如00、01、02...,个位处的0不可省略,否则1后面跟的是11。
(3)在多个文件夹外的大文件夹中新建excel文件,按下ALT+F11,打开VBE窗口,单击插入——模块,复制下面代码,并运行。
Sub CombineFiles()
   Dim path           As String
   Dim FileName       As String
   Dim LastCell       As Range
   Dim Wkb            As Workbook
   Dim WS             As Worksheet
   Dim ThisWB         As String
   Dim fc, f1, fs
Dim MyDir As String
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.GetFolder(ThisWorkbook.path)
   Set fc = f.SubFolders
   For Each f1 In fc
        MyPath = f & "\" & f1.Name
 
   ThisWB = ThisWorkbook.Name
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   FileName = Dir(MyPath & "\*.xlsx", vbNormal)
   Do Until FileName = ""
      If FileName <> ThisWB Then
          Set Wkb = Workbooks.Open(FileName:=MyPath & "\" & FileName)
          For Each WS In Wkb.Worksheets
              Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
              If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
              Else
                  WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
              End If
          Next WS
          Wkb.Close False
      End If
      FileName = Dir()
   Loop
   Application.EnableEvents = True
   Application.ScreenUpdating = True
   
   Set Wkb = Nothing
   Set LastCell = Nothing
  Next
End Sub

0 0
原创粉丝点击