excel-宏

按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