如何将电子表格拆分成具有固定行数的多个电子表格？

Question

我有一个包含433行（还有顶部的标题行）的Excel（2007）电子表格。我需要将其分割成43个包含10行和一个包含剩余3行的电子表格文件。

最好每个电子表格的顶部都有标题行。我应该如何完成这个任务？

- hockey2112

---

在Excel中直接操作只是手工活。您是否打算使用VBA？ - LS_ᴅᴇᴠ

Answer 1

你的宏只是将选择区域中的所有行都拆分了，包括标题行在第一行（因此它只会出现一次，在第一个文件中）。我修改了这个宏以满足你的要求；很容易，查看我写的注释就能知道它是做什么的。

Sub Test()
  Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range        'data (range) of header row
  Dim WorkbookCounter As Integer
  Dim RowsInFile                    'how many rows (incl. header) in new files?

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 10                   'as your example, just 10 rows per file

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))

  For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
    Set wb = Workbooks.Add

    'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it
    wb.SaveAs ThisWorkbook.Path & "\test" & WorkbookCounter
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

希望这能帮到你。

- Fer García

---

太好了！帮我省下了数小时的时间，将一个有345,000行的文件分割成每个文件10,000行。谢谢！ - Bruce Pierson

那段代码按预期工作。感谢您提供如此干净易懂的代码。 - Rohit Sawai

Answer 2

我将@Fer Garcia的代码更新给Mac用户使用，只改变了文件保存方法。

Sub Test()


Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range        'data (range) of header row
  Dim WorkbookCounter As Integer
  Dim RowsInFile                    'how many rows (incl. header) in new files?

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 150                   'as your example, just 10 rows per file

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))

  For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
    Set wb = Workbooks.Add

    'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it

    wb.SaveAs "Test" & WorkbookCounter & ".xls", FileFormat:=57
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

- Mohamed Sami

Answer 3

我更新了Mohamed Sami的代码，用于.xlsx文件格式。

Sub Test()


Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range        'data (range) of header row
  Dim WorkbookCounter As Integer
  Dim RowsInFile                    'how many rows (incl. header) in new files?

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 11                   '10 rows and 1 header

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))

  For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
    Set wb = Workbooks.Add

    'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it

    wb.SaveAs "MyTest" & WorkbookCounter & ".xlsx", FileFormat:=51
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

执行此代码的步骤如下：

1. 打开工作表
2. 按下alt+f11（windows）
3. 右键单击工作表
4. 选择插入模块
5. 粘贴以上代码
6. 单击代码中的任意行
7. 单击绿色（播放）按钮以执行代码

您的文件将保存在“文档”文件夹中。

- Abhishek