x=inputbox("请输入每个文件表头所占的行数:")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set xlsapp = CreateObject("excel.Application")
xlsapp.visible=true
set hb=xlsapp.workbooks.add
hb.saveas(WshShell.CurrentDirectory & "\合并.xls")
Set myfolder = fso.GetFolder(WshShell.CurrentDirectory)
index=1
For Each myfile In myfolder.Files
  if InStr(myfile.name,".xls")<>0 and InStr(myfile.name,"合并.xls")=0 and InStr(myfile.name,"$")=0  then
   set temp=xlsapp.workbooks.open(WshShell.CurrentDirectory & "\" & myfile.name)
   if index=1 then
     temp.Worksheets(1).Rows("1:" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   else
     temp.Worksheets(1).Rows((x+1) & ":" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   end if
   hb.Worksheets(1).Rows(index).PasteSpecial
   fnl=Len(myfile.Name)
   For i = index To hb.Worksheets(1).UsedRange.Rows.Count
      hb.Worksheets(1).Cells(i,temp.Worksheets(1).UsedRange.Columns.Count+1).Value = Left(myfile.Name,fnl-4)
   Next
   hb.Save
   index=hb.Worksheets(1).UsedRange.Rows.Count+1
   temp.close
   set temp=Nothing
  end if
next
hb.worksheets(1).columns.autofit
hb.save
hb.close
set hb=nothing
set myfolder=nothing
xlsapp.quit
Set xlsapp= Nothing
Set fso = Nothing
Set wshell = Nothing 
MsgBox "OK，请打开合并.xls"
复制代码