建立一個文字檔案，拓展名為VBS

將編碼格式改為ansi

Dim MyPath, MyName, AWbName,dirName,curVbsDirDim, fso,xlApp

Set fso = CreateObject("Scripting.FileSystemObject")

curVbsDir=fso.GetFolder(".").Path

dirName=InputBox("輸入檔案的路徑","提示",curVbsDir)

Set xlApp = WScript.CreateObject("Excel.Application")

Dim Wb, WbN,G , Num ,BOX ,fl,curWb

xlApp.ScreenUpdating = False
Set curWb=xlApp.Workbooks.Add()
Num = 0
If Not fso.FolderExists(dirName & "\") Then 
    MsgBox "資料夾" & dirName & "不存在！"
Else 
    On Error Goto 0
    For Each fl In  fso.GetFolder(dirName).Files
        'MsgBox fl.Name & Chr(13) & fl.Path
        If fso.GetExtensionName(fl.Path) = "xls" Or  fso.GetExtensionName(fl.Path) = "xlsx"  Then 
            Num = Num + 1
            Set Wb=xlApp.Workbooks.open(fl.Path)
            'curWb.ActiveSheet.Cells(curWb.ActiveSheet.Range("A65536").End(-4162).Row+1, 1) = fl.Name
            For G = 1 To Wb.Sheets.Count
            	curWb.ActiveSheet.Cells(curWb.ActiveSheet.Range("A65536").End(-4162).Row+1, 1) = fl.Name & " FOR " & Wb.Sheets(G).Name
                Wb.Sheets(G).UsedRange.Copy curWb.ActiveSheet.Cells(curWb.ActiveSheet.Range("A65536").End(-4162).Row+2, 1)        
            Next 
            WbN = WbN & Chr(13) & Wb.Name 
            Wb.Close False    
        End If
    Next 
    xlApp.ScreenUpdating = True
    curWb.SaveAs dirName & "\" & fso.getfolder(dirName).Name & ".xls", 56
    xlApp.visible=True
    xlApp.WindowState=-4137
    MsgBox "共合併了" & Num & "個工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End If
Set fso = Nothing:Set xlApp=Nothing