VBA常用小代码010:将总表数据拆分为多个工作簿

摘要: VBA编程学习与实践

10-12 00:20 首页 Excel之家ExcelHome


HI,各位亲,今天我们分享VBA常用小代码第10篇,按指定字段将总表的数据拆分为多个分表工作簿。

举个栗子,如上图所示的数据表,倘若需要按班级,将该表的数据拆分为1~2~3班三个工作簿,并保留在电脑的指定位置,就可以使用我们今天这篇小代码了。

操作动画演示:

代码比较长,建议新手收藏后用到时会复制粘贴运行就好。


Sub Newbooks()
    Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&
    Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$
    Dim Cll As Range, sht As Worksheet
    Application.ScreenUpdating = False 取消屏幕刷新
    Application.DisplayAlerts = False 取消警告信息提醒,当有重名工作簿时直接覆盖保存。
   
   

    第一部分,用户选择保存分表工作簿的路径。
    With Application.FileDialog(msoFileDialogFolderPicker)
   选择保存工作薄的文件路径
        .AllowMultiSelect = False
        不允许多选
        If .Show Then
            mypath = .SelectedItems(1)
            读取选择的文件路径
        Else
            Exit Sub
            如果没有选择保存路径,则退出程序
        End If
    End With
    If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
   
   
    第二部分遍历总表数据,通过字典将指定字段的不同明细行过滤保存

    Set d = CreateObject("scripting.dictionary") set字典
    Set Rg = Application.InputBox("请框选拆分依据列!只能选择单列单元格区域!", Title:="提示", Type:=8)
    用户选择的拆分依据列
    tCol = Rg.Column 取拆分依据列列标
    tRow = Val(Application.InputBox("请输入总表标题行的行数?"))
    用户设置总表的标题行数
    If tRow = 0 Then MsgBox "你未输入标题行行数,程序退出。": Exit Sub
    Set Rng = ActiveSheet.UsedRange 总表的数据区域
    Set Cll = ActiveSheet.Cells 用于在分表粘贴和总表同样行高列宽的数据格式
    arr = Rng 数据范围装入数组arr
    tCol = tCol - Rng.Column + 1 计算依据列在数组中的位置
    aCol = UBound(arr, 2) 数据源的列数
    For i = tRow + 1 To UBound(arr) 遍历数组arr
        If Not d.exists(arr(i, tCol)) Then
            d(arr(i, tCol)) = i 字典中不存在关键词则将行号装入字典
        Else
            d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i 如果存在则合并行号,以逗号间隔
        End If
    Next
    
   
    第三部分遍历字典取出分表数据明细,建立不同工作簿保存数据。

    kr = d.keys 字典的key集
    For i = 0 To UBound(kr) 遍历字典key值
        If kr(i) <> "" Then 如果key不为空
            r = Split(d(kr(i)), ",") 取出item里储存的行号
            ReDim brr(1 To UBound(r) + 1, 1 To aCol) 声明放置结果的数组brr
            k = 0
            For x = 0 To UBound(r)
                k = k + 1 累加记录行数
                For j = 1 To aCol 循环读取列
                    brr(k, j) = arr(r(x), j)
                Next
            Next
            With Workbooks.Add
            新建一个工作簿
                With .Sheets(1).[a1]
                    Cll.Copy 复制粘贴总表的单元格格式
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Resize(tRow, aCol) = arr 放标题行
                    .Offset(tRow, 0).Resize(k, aCol) = brr 放置数据区域
                    .Select
                End With
                .SaveAs mypath & kr(i), xlWorkbookDefault  保存工作簿
                .Close True 关闭工作簿
            End With
        End If
    Next
    
   
    收尾巴。

    Set d = Nothing 释放字典
    Erase arr: Erase brr 释放数组
    MsgBox "处理完成。", , "提醒"
    Application.ScreenUpdating = True 恢复屏幕刷新
    Application.DisplayAlerts = True 恢复显示系统警告和消息
End Sub


小贴士:

1,当选择拆分依据列时,可以选择整列,比如C列,也可以选择某列中的某个单元格,例如C10。

2,代码可以保留总表的单元格格式、列宽行高等,但无法保留公式。


我是男神,我是星光,喜欢我,就长按下面的二维码吧:

VBA编程学习与实践


Excel函数实战100例 - 第11期
免费公开课时间:10-8(10:00~11:30)
正式课时间:2017-10-15 —— 2017-11-19

点击【阅读原文】了解课程详情:


首页 - Excel之家ExcelHome 的更多文章: