合并excel 宏文件

文件名：Combine.bas

Attribute VB_Name = "模块1"

Sub AsiaFluxCombine()
   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 MyDir As String
   
   MyDir = ThisWorkbook.path & "\"
   ThisWB = ThisWorkbook.Name
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   path = MyDir
   FileName = Dir(path & "\*.xls", vbNormal)
   Do Until FileName = ""
      If FileName <> ThisWB Then
          Set Wkb = Workbooks.Open(FileName:=path & "\" & 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
  Set Wkb = Nothing
  Set LastCell = Nothing
  '删除sheet2和sheet3
  Application.DisplayAlerts = False
  Sheets(Array("Sheet2", "Sheet3")).Select
  Sheets("Sheet3").Activate
  ActiveWindow.SelectedSheets.Delete
  Sheets("Sheet1").Select
  '复制其他工作表中内容到sheet1
  Dim i, j As Long
  j = 1
  For i = 3 To Sheets.Count
  Worksheets(i).Range("1:1").EntireRow.Delete
  Next
  For i = 2 To Sheets.Count
   If Worksheets(i).Name <> ActiveSheet.Name Then
    Worksheets(i).UsedRange.Copy
    ActiveSheet.Paste Sheets(1).Range("a" & j)
    j = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
   End If
  Next
  '删除多余工作表
  Application.DisplayAlerts = False
  Dim sht As Worksheet
  Sheets("Sheet1").Select
  For Each sht In Worksheets
  If sht.Name <> ActiveSheet.Name Then
   sht.Delete
  End If
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox "      ~(≧▽≦)/~"
 End Sub