Excel数据表分割（实战记录）

Dabenshi

发布于 2023-08-24 09:19:32

3040

发布于 2023-08-24 09:19:32

文章被收录于专栏：Dabenshi

使用Excel的宏来实现将每10行数据创建为一个新表的功能。以下是一个示例的VBA代码：

复制代码

Sub 分割数据()
    Dim 原始表 As Worksheet
    Dim 新表 As Worksheet
    Dim 数据区域 As Range
    Dim 行数 As Integer
    Dim 总行数 As Integer
    Dim 表号 As Integer

    行数 = 10   '定义每个新表的行数

    '设置原始表和数据区域
    Set 原始表 = ThisWorkbook.Worksheets("Sheet1")   '将"Sheet1"替换为你的原始表名称
    Set 数据区域 = 原始表.Range("A1").CurrentRegion

    '计算总行数并判断是否需要创建新表
    总行数 = 数据区域.Rows.Count
    If 总行数 <= 行数 Then Exit Sub   '数据行数不足一个新表所需的行数时，退出

    Application.ScreenUpdating = False   '关闭屏幕更新以提高处理速度

    '循环创建新表
    For 表号 = 1 To Int(总行数 / 行数) + 1
        '在当前工作簿中创建新表
        With ThisWorkbook
            Set 新表 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
        End With

        '将数据复制到新表
        数据区域.Copy 新表.Range("A1")

        '删除多余的行
        If 表号 < Int(总行数 / 行数) + 1 Then
            新表.Rows(行数 + 1 & ":" & 新表.Rows.Count).Delete
        End If
    Next 表号

    Application.ScreenUpdating = True   '重新打开屏幕更新

    MsgBox "数据已成功分割为" & Int(总行数 / 行数) + 1 & "个表。"
End Sub

请按照以下步骤操作（Sheet）：

打开Excel，按下ALT + F11打开VBA编辑器。
在左侧的“项目资源管理器”窗格中，找到你的工作簿，并双击打开。
在VBA编辑器的窗口中，插入新模块（Insert -> Module）。
将上述代码复制粘贴到新模块中。
关闭VBA编辑器。
返回Excel界面，在菜单栏中点击“开发者”选项卡，如果没有该选项卡，请在Excel选项中启用“开发者”选项卡。
在“开发者”选项卡中找到“宏”按钮。
点击“宏”按钮，在弹出的对话框中选择“分割数据”，然后点击“运行”。

这样，每10行数据将会被创建为一个新的表格，并且你将得到一个弹出窗口，显示成功分割为多少个表格。注意替换代码中的表格名称和每个新表格的行数，以适应你的实际情况。

如果每10行数据创建一个新的工作簿而不是新的工作表（Sheet），可以使用以下VBA代码：

复制代码

Sub 分割数据()
    Dim 原始表 As Worksheet
    Dim 新表 As Workbook
    Dim 数据区域 As Range
    Dim 行数 As Integer
    Dim 总行数 As Integer
    Dim 表号 As Integer

    行数 = 10   '定义每个新表的行数

    '设置原始表和数据区域
    Set 原始表 = ThisWorkbook.Worksheets("Sheet1")   '将"Sheet1"替换为你的原始表名称
    Set 数据区域 = 原始表.Range("A1").CurrentRegion

    '计算总行数并判断是否需要创建新表
    总行数 = 数据区域.Rows.Count
    If 总行数 <= 行数 Then Exit Sub   '数据行数不足一个新表所需的行数时，退出

    Application.ScreenUpdating = False   '关闭屏幕更新以提高处理速度

    '循环创建新表
    For 表号 = 1 To Int(总行数 / 行数) + 1
        '创建新工作簿
        Set 新表 = Workbooks.Add

        '将数据复制到新工作簿
        数据区域.Copy 新表.Worksheets(1).Range("A1")

        '删除多余的行
        If 表号 < Int(总行数 / 行数) + 1 Then
            新表.Worksheets(1).Rows(行数 + 1 & ":" & 新表.Worksheets(1).Rows.Count).Delete
        End If

        '保存新工作簿
        新表.SaveAs ThisWorkbook.Path & "\新表" & 表号 & ".xlsx"   '根据需要修改保存路径和文件名

        '关闭新工作簿
        新表.Close SaveChanges:=False
    Next 表号

    Application.ScreenUpdating = True   '重新打开屏幕更新

    MsgBox "数据已成功分割为" & Int(总行数 / 行数) + 1 & "个新表。"
End Sub

请注意，此代码将创建新的工作簿，并在每个新工作簿中复制相应的数据。你可以根据需求修改代码中的保存路径和文件名。运行代码后，将显示一个弹出窗口，指示成功分割为多少个新表。

如果需要更改行数或其他相关参数，只需修改代码中相应的行数即可。

修改代码中的数据区域，可以将其更改为你想要分割的数据所在的范围。以下是几种常用的方法：

使用具体的范围地址：你可以将数据区域定义为特定的范围地址，例如"A1:D100"。
使用Cells函数：你可以使用Cells函数指定数据区域的起始单元格和结束单元格，例如Set 数据区域 = 原始表.Range(Cells(1, 1), Cells(100, 4))表示数据从第1行第1列开始，到第100行第4列结束。
使用Named Range：如果你已经为数据区域设置了命名范围，可以直接使用命名范围代替具体的范围地址，例如Set 数据区域 = 原始表.Range("DataRange")，其中"DataRange"是你为数据区域设置的命名范围名称。

请根据你的实际需求选择适合的方法，并将代码中的数据区域相应地进行修改。

如果想将原始数据分割为多个表格，每个表格包含连续的10行数据，并且每个数据只包含在一个表格中，以下是一个示例的 VBA 代码来实现这个功能（不带标题行）：

复制代码

Sub 分割数据()
    Dim 原始表 As Worksheet
    Dim 新表 As Workbook
    Dim 数据区域 As Range
    Dim 总行数 As Integer
    Dim 表号 As Integer
    Dim 起始行 As Integer
    Dim 结束行 As Integer
    Dim 行数 As Integer

    行数 = 10 ' 定义每个新表的行数

    ' 设置原始表和数据区域
    Set 原始表 = ThisWorkbook.Worksheets("Sheet1") ' 将 "Sheet1" 替换为你的原始表名称
    Set 数据区域 = 原始表.Range("A1").CurrentRegion

    ' 计算总行数并判断是否需要创建新表
    总行数 = 数据区域.Rows.Count
    If 总行数 <= 行数 Then Exit Sub ' 数据行数不足一个新表所需的行数时，退出

    Application.ScreenUpdating = False ' 关闭屏幕更新以提高处理速度

    ' 循环创建新表
    For 表号 = 1 To Int(总行数 / 行数) + 1
        ' 创建新工作簿
        Set 新表 = Workbooks.Add

        ' 设置新表的起始行和结束行
        起始行 = (表号 - 1) * 行数 + 1
        结束行 = WorksheetFunction.Min(总行数, 表号 * 行数)

        ' 将数据复制到新工作簿
        数据区域.Rows(起始行 & ":" & 结束行).Copy 新表.Worksheets(1).Range("A1")

        ' 保存新工作簿
        新表.SaveAs ThisWorkbook.Path & "\新表" & 表号 & ".xlsx" ' 根据需要修改保存路径和文件名

        ' 关闭新工作簿
        新表.Close SaveChanges:=False
    Next 表号

    Application.ScreenUpdating = True ' 重新打开屏幕更新

    MsgBox "数据已成功分割为" & Int(总行数 / 行数) + 1 & "个新表。"
End Sub

这段代码将会根据每个新表的起始行和结束行，将原始数据的对应部分复制到新表中，保证每个数据只出现在一个表格中，同时每个新表包含连续的10行数据。

请注意，在代码中，我假设原始数据从第一行开始，且每个新表都保存为单独的Excel文件。你可以根据实际需求进行修改。

如果你想在每个新表中包含标题行并分割数据，可以使用以下修订版的 VBA 代码：

复制代码

Sub 分割数据()
    Dim 原始表 As Worksheet
    Dim 新表 As Workbook
    Dim 数据区域 As Range
    Dim 总行数 As Integer
    Dim 表号 As Integer
    Dim 起始行 As Integer
    Dim 结束行 As Integer
    Dim 行数 As Integer

    行数 = 10 ' 定义每个新表的行数

    ' 设置原始表和数据区域
    Set 原始表 = ThisWorkbook.Worksheets("Sheet1") ' 将 "Sheet1" 替换为你的原始表名称
    Set 数据区域 = 原始表.Range("A1").CurrentRegion

    ' 计算总行数并判断是否需要创建新表
    总行数 = 数据区域.Rows.Count
    If 总行数 <= 行数 Then Exit Sub ' 数据行数不足一个新表所需的行数时，退出

    Application.ScreenUpdating = False ' 关闭屏幕更新以提高处理速度

    ' 循环创建新表
    For 表号 = 1 To Int(总行数 / 行数) + 1
        ' 创建新工作簿
        Set 新表 = Workbooks.Add
        With 新表.Worksheets(1)
            ' 设置新表的起始行和结束行
            起始行 = (表号 - 1) * 行数 + 1
            结束行 = WorksheetFunction.Min(总行数, 表号 * 行数)

            ' 将标题行复制到新工作簿
            数据区域.Rows(1).Copy .Range("A1")

            ' 将数据复制到新工作簿
            数据区域.Rows(起始行 & ":" & 结束行).Copy .Range("A2")
        End With

        ' 保存新工作簿
        新表.SaveAs ThisWorkbook.Path & "\新表" & 表号 & ".xlsx" ' 根据需要修改保存路径和文件名

        ' 关闭新工作簿
        新表.Close SaveChanges:=False
    Next 表号

    Application.ScreenUpdating = True ' 重新打开屏幕更新

    MsgBox "数据已成功分割为" & Int(总行数 / 行数) + 1 & "个新表，并且包含标题行。"
End Sub

这段代码在每个新表中通过将标题行和对应的数据行复制到新工作簿来实现分割。新工作簿中的第一行是标题行，接下来的行是对应的数据行。

请注意，这段代码也假设原始数据从第一行开始，并且每个新表保存为单独的Excel文件。你可以根据实际需求进行修改。

本文参与腾讯云自媒体同步曝光计划，分享自作者个人站点/博客。

原始发表：2023/07/17 ，如有侵权请联系 cloudcommunity@tencent.com 删除

excel