把一个工作表按每100行拆分成多个Excel文件

lrh788

Sub 按输入的行数拆分成多簿()
     Dim wbk As Workbook
     Application.ScreenUpdating = False
      t = Timer
      n = Application.InputBox(prompt:="请输入每个表格的行数", Title:="操作提示", Default:=100, Type:=1)
      With Sheet1
         For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step n
             k = k + 1
             Set wbk = Workbooks.Add
             .Rows(1).Copy wbk.Sheets(1).[a1] '表头
             .Rows(i).Resize(n).Copy wbk.Sheets(1).[a1] '数据
              wbk.Close True, ThisWorkbook.Path & "\" & k
         Next
     End With
     Set wbk = Nothing
     Application.ScreenUpdating = True
     MsgBox "拆分时间：" & Format(Timer - t, "0.000") & "秒"
End Sub
Sub 按输入的行数拆分成多表()
    Dim r%, c%, i%, m%
    Dim arr, brr
    Dim rng As Range
    Dim ws As Worksheet
    t = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sht In Worksheets
       If sht.Name <> Sheet1.Name Then sht.Delete
    Next
    m = Application.InputBox(prompt:="请输入每个表格的行数", Title:="操作提示", Default:=100, Type:=1)
      If m = 0 Then
      Exit Sub
    End If
    With Worksheets("Sheet1")
       r = .Cells(.Rows.Count, 1).End(xlUp).Row
       c = .Cells(1, .Columns.Count).End(xlToLeft).Column
       Set rng = .Range(.Cells(1, 1), .Cells(1, c))
    End With
    For i = 2 To r Step m
       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
       With ws
          rng.Copy .Range("a1")
          Worksheets("Sheet1").Cells(i, 1).Resize(m, c).Copy .Range("a2")
       End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
     MsgBox "拆分时间：" & Format(Timer - t, "0.000") & "秒"
End Sub
Sub 按照固定行数拆分多个工作簿()
    Dim r, c, i, n, k, bt As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    St = Application.FileDialog(msoFileDialogFolderPicker).Show
    If St <> 0 Then
        StFile = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    Else
        Exit Sub
    End If
    Set Rg = Application.InputBox("请选择标题所在的行（可以单击其中一个单元格）", "选择", Type:=8)
    bt = Rg.Row
    n = Application.InputBox(prompt:="请输入每个表格的行数", Title:="操作提示", Default:=100, Type:=1)
    r = Range("A" & Rows.Count).End(xlUp).Row
    c = Cells(1, Columns.Count).End(xlToLeft).Column
    k = IIf(r - bt Mod r, Int((r - bt) / n), Int((r - bt) / n) + 1)
    For i = 0 To k
        Workbooks.Add
        ActiveWorkbook.SaveAs FileName:=StFile & "\" & "分表" & i & ".xlsx"
        ActiveSheet.Range("A1").Resize(bt, c).Copy ActiveSheet.Range("A1")
        ActiveSheet.Range("A" & bt + i * n + 1).Resize(n, c).Copy ActiveSheet.Range("A" & bt + 1)
        ActiveWorkbook.Close True
    Next
    MsgBox "拆分耗时" & Timer - t & "秒"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub                                                                                                         

lrh788

Sub 按输入的行数拆分成多簿()
      Dim wbk As Workbook
      Application.ScreenUpdating = False
       t = Timer
       n = Application.InputBox(prompt:="请输入每个表格的行数", Title:="操作提示", Default:=100, Type:=1)
       With Sheet1
          For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step n
              k = k + 1
              Set wbk = Workbooks.Add
              .Rows(1).Copy wbk.Sheets(1).[a1] '表头
             .Rows(i).Resize(n).Copy wbk.Sheets(1).[a1] '数据
              wbk.Close True, ThisWorkbook.Path & "\" & k
          Next
      End With
      Set wbk = Nothing
      Application.ScreenUpdating = True
      MsgBox "拆分时间：" & Format(Timer - t, "0.000") & "秒"
End Sub
请教各位老师和大神，此代码按行拆分为多个工作簿后，从第二个工作簿起就没有表头，应如何添加表头？

kxs5555

请教各位老师和大神，此代码按行拆分为多个工作簿后，从第二个工作簿起就没有表头，应如何添加表头？

吾股丰登

kxs5555 发表于 2021-10-14 20:35
请教各位老师和大神，此代码按行拆分为多个工作簿后，从第二个工作簿起就没有表头，应如何添加表头？

copy表头所在的行  复制表头

szqhb

yjjhc 发表于 2020-6-28 08:56
Sub lsc()
    Dim wbk As Workbook
    Application.ScreenUpdating = False

For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step 100'将1改为2，即从第二行起取数