VBA应用笔记2——自动拆分工作表的实现

1，需求说明：

     （1）需求1：按某列对数据表进行拆分，列号由用户输入确定，如按D列拆分，则由用户在input对话框中输入D，如按F列拆分，则由用户在input对话框中输入F。

    （ 2）需求2：每一项拆分结果另存为一个新的工作簿，新工作簿命名为拆分条目，新工作保存路径为：当前工作簿下名为“拆分结果”的文件夹内；若没有该文件夹，则提前新建一个。

     （3）需求3：将本功能加载到EXCEL主程序菜单栏中，方便重用。如下图：

 

2，处理思路：

     2.1 拆分工作表代码实现：

      （1）首先判定当前目录下是否有“拆分结果”文件夹，若没有，则新建。

      （2）其次通过inputbox 接受用户输入的需要拆分的列

      （3）将拆分的列赋值给字典去重

      （4）遍历字典的K值，通过筛选功能autofilter,筛选出每项拆分结果

      （5）赋值筛选结果到新的工作簿，并保存

   2.2，加载功能到菜单栏的实现：

         （1）文件→另存为→Excel加载宏（*.xlam或者*.xla文件类型，97-2003为*.xla文件类型）。

           (2）选定文件类型后，会直接找到默认路径“Microsoft Addins",注意：不要更改此路径。直接保存即可。

        （3）开发工具→加载宏→勾选前面保存的加载宏文件。

        （4）文件→选项→自定义功能区→从下列位置选择命令→添加→完成。

3，本例代码：

Sub 拆分()
Dim myd As Object
Dim arr
Dim folder As String
Dim wb As Workbook
Dim sht As Worksheet
Dim n, m, k, r, input_str, column_num
folder = ActiveWorkbook.Path & "\拆分结果"
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder  '判定当前目录下是否有拆分结果文件夹，若没有，则新建
Set myd = CreateObject("scripting.dictionary")          '创建字典对象，通过字典键不可重复的特性，确定被拆分列拆分条目
Set sht = ActiveWorkbook.ActiveSheet

input_str = InputBox("请输入要按哪列拆分(如输入:A）>>>>>")
column_num = sht.Range(input_str & "1").Column  '通过输入指定列的字母表示编号，计算出列的数字编号
m = sht.Range(input_str & "1048576").End(xlUp).Row  '统计被拆分列总行数
arr = sht.Range(Cells(2, column_num), Cells(m, column_num))  '将被拆分列赋值给数组arr
'利用字典键值不可重复的特性透视被拆分列，确定被拆分的条目
For n = LBound(arr) To UBound(arr)
 myd(arr(n, 1)) = 1
Next
For Each k In myd.Keys
    Set wb = Workbooks.Add
    
    sht.Range("A1").AutoFilter Field:=column_num, Criteria1:=k
    sht.UsedRange.Copy wb.Sheets(1).Range("b1")
    '为新工作表添加序号列
    For r = 2 To wb.Sheets(1).Range("b1048576").End(xlUp).Row
       wb.Sheets(1).Range("a" & r) = r - 1
    Next
    wb.Sheets(1).Range("a1") = "序号"
    
    wb.SaveAs folder & "\" & k & ".xlsx"    '保存工作表
    wb.Close
    sht.Range("A1").AutoFilter
Next
MsgBox "已完成"
End Sub

4，加载功能到菜单栏实现步骤截图：

    步骤1：另存文件为 *xlam

 

 

    步骤2：设置加载宏

 

 

 

    步骤3：自定义功能区

 

 

 5，本例练习数据：

https://files.cnblogs.com/files/li-cz/VBA%E5%AE%9E%E4%BE%8B2%E2%80%94%E6%8B%86%E5%88%86%E5%B7%A5%E4%BD%9C%E8%A1%A8%E7%BB%83%E4%B9%A0%E6%95%B0%E6%8D%AE.rar?t=1658222160