Excel_Sheet拆分及合并

Sub MergeFile()
        Dim MyPath$, MyName$, sht As Worksheet, SaveFileName$, Extension$, WshShell As Object
        ' Set MyPath = ThisWorkbook.Path & "\"
        SaveFileName = Format(Now(), "yyyy_MM_dd_HH_mm_ss")
        Application.CutCopyMode = False
100:
        Extension = InputBox("请输入要合并的文件的扩展名：" & vbNewLine & "xlsx" & vbNewLine & "csv" & vbNewLine & "xls", "请输入文件类型", "xlsx")
        Extension = LCase(Trim(Extension))
        If (StrComp(Extension, "xlsx", 1) = 0) Xor (StrComp(Extension, "csv", 1) = 0) Xor (StrComp(Extension, "xls", 1) = 0) Then
        Else
            GoTo 100
        End If
200:
        MyPath = InputBox("请输入要合并的文件的文件夹绝对路径：", "请输入文件夹路径", ThisWorkbook.Path)
        MyPath = Trim(MyPath)
        ' Dim fso As New Scripting.FileSystemObject
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.folderexists(MyPath) Then
            GoTo 200
        End If
        Set fso = Nothing
        MyPath = MyPath & "\"
        MyName = Dir(MyPath & "*." & Extension)
        Application.ScreenUpdating = False
        Do While Len(MyName) > 0
            If MyName <> ThisWorkbook.Name Then
                With GetObject(MyPath & MyName)
                    For Each sht In .Sheets
                        sht.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    Next
                    .Close False
                End With
            End If
            MyName = Dir
        Loop
        Application.DisplayAlerts = False
        Application.CutCopyMode = False
        SaveFileName = MyPath & SaveFileName & "." & Split(ActiveWorkbook.Name, ".")(UBound(Split(ActiveWorkbook.Name, ".")))
        ActiveWorkbook.SaveAs SaveFileName, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
        Application.DisplayAlerts = True
        MsgBox "已合并" & vbNewLine & "并保存！", 64, "完成"
        ActiveWorkbook.Close False
        Application.DisplayAlerts = False
        Application.Quit
        Set WshShell = CreateObject("WScript.Shell")
        WshShell.Run "taskkill /f /im EXCEL.exe"
        Set WshShell = Nothing
    End Sub
    Sub SplitFile()
        Dim MyPath$, sht As Worksheet, SaveFileName$, Extension$, WshShell As Object, MyFileFormat As XlFileFormat
        Application.CutCopyMode = False
100:
        Extension = InputBox("请输入要拆分后的文件的扩展名：" & vbNewLine & "xlsx" & vbNewLine & "csv" & vbNewLine & "xls", "请输入文件类型", "xlsx")
        Extension = LCase(Trim(Extension))
        If (StrComp(Extension, "xlsx", 1) = 0) Xor (StrComp(Extension, "csv", 1) = 0) Xor (StrComp(Extension, "xls", 1) = 0) Then
        Else
            GoTo 100
        End If
        Select Case Extension
            Case "csv"
                MyFileFormat = XlFileFormat.xlCSV
            Case "xlsx"
                MyFileFormat = XlFileFormat.xlOpenXMLWorkbook
            Case "xls"
                MyFileFormat = XlFileFormat.xlExcel8
            Case Else
                MyFileFormat = XlFileFormat.xlOpenXMLWorkbook
        End Select
200:
        MyPath = InputBox("请输入要拆分的文件的文件夹绝对路径：", "请输入文件夹路径", ThisWorkbook.Path)
        MyPath = Trim(MyPath)
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.folderexists(MyPath) Then
            GoTo 200
        End If
        Set fso = Nothing
        MyPath = MyPath & "\"
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.CutCopyMode = False
        For Each sht In Sheets
            sht.Copy
            SaveFileName = MyPath & sht.Name & "." & Extension
            ActiveWorkbook.SaveAs SaveFileName, FileFormat:=MyFileFormat, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
            ActiveWorkbook.Close True
        Next
        Application.DisplayAlerts = True
        MsgBox "已拆分" & vbNewLine & "并保存！", 64, "完成"
        ActiveWorkbook.Close False
        Application.DisplayAlerts = False
        Application.Quit
        Set WshShell = CreateObject("WScript.Shell")
        WshShell.Run "taskkill /f /im EXCEL.exe"
        Set WshShell = Nothing
    End Sub