按alt+f11進入巨集，新建模組， f5執行

'用來對EXCEL進行自動分表，分成原表+序號，第一行表頭全部複製，其他資料按需要分到相應的表中
Sub SperateEveryHundredRow()

    '定義分割後的表除表頭外有多少行
    Dim EveryRow As Integer
    EveryRow = 500

    'bookName : 主工作簿名(temp)
    Dim BookNameTemp As String
    BookNameTemp = Windows.Application.ActiveWorkbook.Name


    Dim
 
 BookName
    BookName = Left(BookNameTemp, InStr(BookNameTemp, ".") - 1)

    '主工作表名
    Dim tableName As String
    tableName = ActiveSheet.Name()

    '主表的行數,這裡有可能無法運算出來，需要手動填寫實際表格的行數
    Dim tableRows As Integer
    tableRows = ActiveSheet.Range("A65535").End(xlUp).Row

    '分表的個數，這裡有點問題，沒有ceil函式，無法進行上浮運算
 

    Dim tableNumber As Integer
    tableNumber = Int(tableRows / EveryRow)

         '從第一個分表開始，至到把所有的表填充完畢
         For Index = 1 To tableNumber

          Dim newBookName As String
          newBookName = BookName & "-" & Index

           '  Workbooks.Add.Name(newBookName)
           '下面新增一個工作表，用工作簿+序號的命名方式
 


           Dim insertTable As Boolean
           insertTable = addWorkSheetCopyFirstRow(tableName, newBookName)

         'startRowEvery:開始複製的行數，最後的加一為了隔開表頭
          Dim startRowEvery As Integer
          startRowEvery = (Index - 1) * EveryRow + 1 + 1

          'endRowEvery:結束複製的行數，最後的加一為了隔開表頭
          Dim endRowEvery As Integer
          endRowEvery = startRowEvery + EveryRow - 1

           '複製EveryRow行
           Worksheets(tableName).Activate
            Rows(startRowEvery & ":" & endRowEvery).Select
            Selection.Copy

                  Sheets(newBookName).Activate

                  Rows(2).Select
                  ActiveSheet.Paste

                 Sheets(tableName).Activate

        Next

End Sub
'函式addWorkSheetCopyFirstRow(tableName,sName)用來新建一個以sName的工作表，並且將tableName工作表的第一行復制到新工作表的第一行
Function addWorkSheetCopyFirstRow(ByVal tableName As String, ByVal sName As String) As Boolean

    addWorkSheetCopyFirstRow = False

    '插入制定名稱的工作表
    Worksheets.Add.Name = sName

    Debug.Print "建立新工作表"; sName; "成功"

    '選中主表的第一行
     Worksheets(tableName).Activate
     Rows(1).Select
    '複製選中的第一行
    Selection.Copy

    '選中新建表的第一行
    Sheets(sName).Activate
    Rows(1).Select
    '貼上
    ActiveSheet.Paste

    addWorkSheetCopyFirstRow = True
    Worksheets(tableName).Activate '最後將當前活動工作表還原為主表

    Debug.Print "已經複製第一行到"; sName; "工作表"

End Function

Sub Final()
    Dim sht As Worksheet
    Dim MyBook As Workbook
    Set MyBook = ActiveWorkbook
    For Each sht In MyBook.Sheets
        sht.Copy
        ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & sht.Name, FileFormat:=xlNormal     '???????EXCEL????
        ActiveWorkbook.Close
    Next
    MsgBox "Congratuations! Save worksheets to workbooks completed."
End Sub