把excel中的数据,按条件分割成多个文件

excel 专栏收录该内容
3 篇文章 0 订阅

要求

有个excel文件,把文件中的数据按照某列,将相同的数据存为一个excel文件。

VBA代码

执行下面的代码后,会在该excel的同级目录下创建一个新文件夹“拆分出的表格”,拆分后生成的新文件会存在这个目录下。

我拆分了30个文件,大约一分钟时间。请耐心等待。
如果你感觉没有进度,你可以看一下同级目录下“拆分出的表格”文件夹中是否在缓慢生成新的文件。

Sub 拆分成多个文件()

    '输入用户想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("请输入拆分工作表的名称:")
    Worksheets(sheet_name).Select

    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如A):")

    '输入拆分的开始行,要求输入的是数字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)

    '暂停屏幕更新
    Application.ScreenUpdating = False

    '工作表的总行数
    Dim end_row
    end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row

    '遍历计算所有拆分表,每个拆分表的格式为"表名称,表行数"
    '对于二维数组,ReDim只能扩充最后一维,因此sheet_map行不变,扩充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0

    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With

    '根据前面计算的拆分表,拆分成单个文件
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '创建最终数据文件夹
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '创建新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xls"
        ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
        ActiveSheet.Name = sheet_map(0, i)
        '激活当前工作簿,ThisWorkbook表示当前跑代码的工作簿
        ThisWorkbook.Activate

        '拷贝条目数据(即最前面不需要拆分的数据行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
        '拷贝拆分表的专属数据
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)

        '保存文件
        Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
    Next

    '进行屏幕更新
    Application.ScreenUpdating = True

    MsgBox "拆分工作表完成"

End Sub

遇到的小问题

宏被禁用

https://jingyan.baidu.com/article/4dc408489963b5c8d846f174.html
https://jingyan.baidu.com/article/c910274bcfaa32cd361d2db1.html
设置后如果无效,请关闭excel后重新打开。

  • 4
    点赞
  • 4
    评论
  • 10
    收藏
  • 打赏
    打赏
  • 扫一扫,分享海报

评论 4 您还未登录,请先 登录 后发表或查看评论
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页

打赏作者

win_turn

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值