如何把excel中的多行数据按行数拆分成多个

客官°小女子只卖身不卖艺 2022-12-28 00:35 147阅读 0赞

> 原创链接 知乎 郭大牛 谢谢！解决了问题仅此记录一下  
> https://zhuanlan.zhihu.com/p/81580481?from\_voters\_page=true

首先打开一个excel 添加宏  
![在这里插入图片描述][20201212152541663.png]

将代码编辑到宏中

Sub copybat()
        Dim i, j, k, m, r As Integer
        Dim n, total_data As Long
        Dim path As String
        Dim title_area, data_column, data_areas As Range
       
        Set title_area = Application.InputBox(prompt:="请用鼠标选择表头及表标题所在区域", Title:="选择", Type:=8) '选取表头区域
        Set data_column = Application.InputBox(prompt:="请鼠标选择需要拆分数据的开始行区域", Title:="选择", Type:=8) '选取拆分起始处
        m = data_column.Row      '获取分割开始行所在区域行号
        r = data_column.Column   '获取分割开始行所在区域列号
        j = data_column.Columns.Count   '获取分割开始行区域列数
        i = Application.InputBox(prompt:="请输入每次分割数据条目数", Title:="选择")
      
       '获取需要分割的数据总条数。这里，可以用两种办法获取到数据区域的尾部行号
          '第一种，使用传统的：End(xlDown).Row，优点是速度快，缺点是有空白行时会出错
          '第二种，使用查找方式find，优点是基本不会出错，缺点是条数较多时候可能会慢一点
       'total_data = Cells(data_column(1, 1)).End(xlDown).Row - m + 1
        total_data = Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row - m + 1
        If MsgBox("本次分割文件数据总数为:" & total_data & "条，将会被分割成" & WorksheetFunction.RoundUp(total_data / i, 0) & "个文件，" _
                    & "点击“确定”开始分割，点击“取消”返回", vbOKCancel, "确认") = vbOK Then
            Filename = Application.InputBox(prompt:="请输入分割后的文件主名，默认为“分割文件”", Title:="选择", Default:="分割文件")
            With Application.FileDialog(msoFileDialogFolderPicker)  '获取分割后的文件存储路径
                If .Show = False Then Exit Sub
                    path = .SelectedItems(1) & "\" '加入"\",否则，文件会被存储到选定路径的上一层
            End With
            Application.ScreenUpdating = False
            k = 0   '第几次分割输出，用于标识分割文件次数
            For n = m To total_data Step i   '从开始分割的行往下计数
                Set data_areas = Range(Cells(n, r), Cells(n + i - 1, j))   '设置每次循环体内的分割数据主体
                Application.Union(title_area, data_areas).Select           '把表头区域以及本次循环体内的数据区域进行合并
                Selection.Copy
                Workbooks.Add
                Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                , SkipBlanks:=False, Transpose:=False      '特殊粘贴：包含源格式的粘贴，以便保持所有格式一致
               k = k + 1
               ActiveWorkbook.SaveAs Filename:=path & Filename & "_" & k & ".xlsx", FileFormat:= _
                xlOpenXMLWorkbook, CreateBackup:=False      '按照既有的文件名、路径、循环次数合并起来存储文件
                ActiveWindow.Close
            Next n
            MsgBox "文件分割完毕！", vbDefaultButton1, "提示"
        End If
        Application.ScreenUpdating = True
    End Sub

![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3FxXzQzMjc3NDA0_size_16_color_FFFFFF_t_70]  
双击启动宏  
![在这里插入图片描述][watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3FxXzQzMjc3NDA0_size_16_color_FFFFFF_t_70 1]  
![在这里插入图片描述][20201212152844852.png]  
![在这里插入图片描述][20201212152906703.png]  
![在这里插入图片描述][20201212152920979.png]  
![在这里插入图片描述][20201212152945818.png]

> 原创链接 知乎 郭大牛 谢谢！解决了问题仅此记录一下  
> https://zhuanlan.zhihu.com/p/81580481?from\_voters\_page=true  
> ![在这里插入图片描述][20201212153025844.png]

[20201212152541663.png]: /images/20221120/065944ded79e49cbbdf744ad204dd0d7.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3FxXzQzMjc3NDA0_size_16_color_FFFFFF_t_70]: /images/20221120/87cca9c147004bf1aed2fe7b851d28d7.png
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L3FxXzQzMjc3NDA0_size_16_color_FFFFFF_t_70 1]: /images/20221120/7e42b6875dfc494d9199f9e017f29ee6.png
[20201212152844852.png]: https://img-blog.csdnimg.cn/20201212152844852.png
[20201212152906703.png]: https://img-blog.csdnimg.cn/20201212152906703.png
[20201212152920979.png]: https://img-blog.csdnimg.cn/20201212152920979.png
[20201212152945818.png]: https://img-blog.csdnimg.cn/20201212152945818.png
[20201212153025844.png]: https://img-blog.csdnimg.cn/20201212153025844.png