快好知 kuaihz订阅观点

 

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

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

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

用循环嵌套速度慢,用数组 字典的方式处理速度会快很多。经测试,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精英之家】后方可下载。

本站资源来自互联网,仅供学习,如有侵权,请通知删除,敬请谅解!
搜索建议:拆分  拆分词条  单独  单独词条  关键字  关键字词条  使用  使用词条  工作  工作词条  
办公

 不要傻傻的插入PPT啦,这样处理...

我们在日常办公中都需要用PPT来进行展示,可是你知道在做图片的时候,该怎么才能让图片更加生动形象呢?一起跟我来看看吧。一、分割效果我们可以利用表格来进行处理,只...(展开)

办公

 Excel097 | 数字与文本...

问题来源朋友留言:韩老师您好,请教一下怎么用LEFT公式把A列中的工号和员工姓名分开到B列(纯数字)和C列(RIGHT公式,纯中文姓名)?谢谢!数据如下:实现方...(展开)