使用VBA将一个EXCEL大表自动分成一系列小表（保留首行）

   最近工作中需要将一个4万行的大EXCEL表格分成一系列小表格，每个小表格500行。如果手工操作，工作量巨大；根据之前写的将excel表格自动筛选为一系列表格的原理，这里进行了vba自动代码的编写，下面粘贴如下:

'用来对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

'Final宏用来将工作表转化为工作簿，在执行完上述操作后执行本次操作，在源工作簿目录下生成一系列的和源工作簿命名格式相似的工作簿。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