网上找excel VBA程序,有现成的

谢谢~~~~

Sub Macro2()
'
' Macro2 Macro
'
' 快捷键: Ctrl+d
'
      Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   FileToOpen_N = Application.GetOpenFilename("xlsx文件,*.xlsx", _
   Title:="请选择要合并工作簿：", MultiSelect:=True)
   Newbz = 0
   On Error Resume Next
   For Each FileToOpen In FileToOpen_N
      If FileToOpen <> False Then
         If Newbz = 0 Then
            Booknum = Application.SheetsInNewWorkbook
            Application.SheetsInNewWorkbook = 1
            Workbooks.Add
            Application.SheetsInNewWorkbook = Booknum
            NewBookName = ActiveWorkbook.Name
            Sheets(1).Name = "sheet_tmp"
            Newbz = 1
         End If
         Set OpenBook = Workbooks.Open(FileToOpen)
         For Each Xlsheet In OpenBook.Sheets
            Xlsheet.Copy Before:=Workbooks(NewBookName).Sheets("sheet_tmp")
         Next
         OpenBook.Close SaveChanges:=False
      End If
   Next
   Workbooks(NewBookName).Sheets("sheet_tmp").Delete
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub