L罗乐 / 数据汇总 / 使用VBA按某列中的关键字拆分为单独的工作...

0 0

   

使用VBA按某列中的关键字拆分为单独的工作簿

2017-12-06  L罗乐

前言:工作簿数据的拆分,有各种各样的需求,本示例介绍其中的一种需求实现,后续将会陆续补充相关内容。

借鉴此示例,你可以将信贷台账等按机构拆分开来,总之,举一返三,这方面的应用不时都会用到。

用循环嵌套速度慢,用数组 字典的方式处理速度会快很多。经测试,5万笔数据,132列,用时23秒完成拆分。

数据源:


结果:


Code:

'function:将当前工作表按第2列中的关键字拆分为各个不同的工作簿

'需要在VBE工具-引用中添加windows script Host Object Model

Sub SplitSht()

'变量声明

    Dim tm, Fso As FileSystemObject, sfolder$, wb As Workbook, arr

    Dim rng As Range, lastRow&, lastCol%, d As Object, k, t, sh As Worksheet, i&

    

    tm = Timer    '计时开始

    '创建文件系统对象

    Set Fso = CreateObject('Scripting.FileSystemObject')

    '在当前文件夹中创建一个子目录用于存放拆分好的工作簿文件

    sfolder = ThisWorkbook.Path & '\分表'

    '若子目录不存在,创建之

    If Fso.FolderExists(sfolder) = False Then Fso.CreateFolder sfolder


    '关闭屏幕更新,防止闪屏,加快处理速度

    Application.ScreenUpdating = False

    '关闭使用工作簿的 SaveAs 方法覆盖现有文件,“覆盖”警告默认为“No”

    '当 DisplayAlerts 属性设置等于 False 时,Excel 选择“Yes”响应。

    Application.DisplayAlerts = False


    '对Sheet1表进行操作,可据实修改

    With Sheets('Sheet1')

        '将Sheet1表单元格区域A1:C1(字段名)赋给对象变量rng

        Set rng = .Range('A1:EB1')

        '取B列最后一个有数据的单元格所在行行号赋给变量lastRow

        lastRow = .Range('B' & Rows.Count).End(xlUp).Row

        '根据不同的Office版本(2007为12.0),取第一行最后一个有数据的单元格所在列列号赋给变量 lastCol

        If Application.Version >= '12.0' Then

            lastCol = .Range('XFD1').End(xlToLeft).Column

        Else

            lastCol = .Range('IV1').End(xlToLeft).Column

        End If

        '将关键字所在列中B1到B列最后一个有数据的单元格组成的区域赋给数组arr

        '实际运用中关键字所在列据实修改

        arr = .Range('B2:B' & lastRow)

        '创建字典对象

        Set d = CreateObject('scripting.dictionary')

        '        Debug.Print UBound(arr)

        '循环,从1到数组arr第一维最大下标

        For i = 1 To UBound(arr)


            '如果字典中不存在arr(i, 1)对应的关键字,则


            If Not d.Exists(arr(i, 1)) Then

                '添加关键字及条目

                '首次循环时,条目为单元格A2向右扩展1行3列的单元格区域即A2:D2

                'i要加1是因为首次代入的变量为1,加1后变为2, Cells(2, 1)表示A2


                Set d(arr(i, 1)) = Cells(i 1, 1).Resize(1, lastCol)

                '如果字典中存在arr(i, 1)对应的关键字,则

            Else

                '用Union方法将原有的条目和新添加的条目组合为一个区域

                '字典的关键字不可以修改,但条目是可以不断修改的

                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i 1, 1).Resize(1, lastCol))

            End If

        Next

    End With


    '将字典中的关键字赋给变量k

    k = d.Keys

    '将字典中的条目赋给变量t

    t = d.Items

    '    Debug.Print d.Count


    '循环,从0到关键字的数量-1

    For i = 0 To d.Count - 1

        '新建一个工作簿并指定类型

        Set wb = Workbooks.Add(xlWBATWorksheet)

        '对新工作簿中的第1张表进行操作

        With wb.Sheets(1)

            '复制rng表示的字段名到新工作簿第1张表A1单元格开始的位置

            rng.Copy .Range('A1')

            '将关键字对应的条目复制到新工作簿第1张工作表A2单元格起的位置

            '条目就是一个区域,可直接cp

            t(i).Copy .Range('A2')

        End With

        '保存新建的工作簿,文件名为各个关键字,扩展名为.xlsx

        '加Clean函数是为防止关键字中有非打印字符,造成文件不能保存错误

        wb.SaveAs Filename:=ThisWorkbook.Path & '\分表\' & WorksheetFunction.Clean(k(i)) & '.xlsx'

        '关掉新建工作簿

        wb.Close

    Next i


    '释放对象变量

    Set rng = Nothing: Set d = Nothing

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    MsgBox '拆分完毕!用时' & Timer - tm & '秒', 64, '提示'

End Sub



看图:


附件下载:此文已同步至【知嗒】知识号【Excel精英之家】,相关附件可下载安装【知嗒】app应用,注册一个账号,搜索并关注【Excel精英之家】,加群【Excel精英之家】后方可下载。


    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。如发现有害或侵权内容,请点击这里 或 拨打24小时举报电话:4000070609 与我们联系。

    猜你喜欢

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多
    喜欢该文的人也喜欢 更多