Excel VBA 宏 拆分Excel表

问题：
excel 文件 如下：

num    char key
1     a    关键字1
1     a    关键字1
1     a    关键字1
1     a    关键字1
2     b    关键字2
2     b    关键字2
2     b    关键字2
2     b    关键字2

按照关键字拆分成 多个 excle 表（非sheet）

关键字1.xls
num    char key
1     a    关键字1
1     a    关键字1
1     a    关键字1
1     a    关键字1

关键字2.xls
num    char key
2     b    关键字2
2     b    关键字2
2     b    关键字2
2     b    关键字2

1.思路

    生成字典，保存相应分组对应的行数，直接根据行数做拆分
    

2.VB脚本

    Sub test()
    '
    ' test 宏.
    '
    Dim d As Object, bt, arr, i% '%代表为数值类型
    Set d = CreateObject("Scripting.Dictionary") ’创建一个字典对象
    bt = Sheet1.Range("A1:J1")  '选取第一行有效范围。记录标题
    arr = Sheet1.Range("A1").CurrentRegion    '获取数据范围
    For i = 2 To UBound(arr)    '获取地址字典，从第二行开始，UBound(arr) 行数，同 UBound(arr,1)
        If Not d.Exists(arr(i, 10)) Then    ’判断字典是否已经收录, 生成的字典为 关键字-行数
            d(arr(i, 10)) = 1
        Else
            d(arr(i, 10)) = d(arr(i, 10)) + 1
        End If
    Next    
    Rem 遍历词典
    Dim objKeys, objItems
    objKeys = d.Keys    '关键字
    objItems = d.Items    '行数
    For i = 0 To d.Count - 1    '循环处理关键字，写入新的文件
        If i = 0 Then    '单独处理第二行
            startline = 2
            endline = i + objItems(i) + 1
            'MsgBox objKeys(i) & "start " & i + 1 & "end " & i + objItems(i)
        Else    '其他关键字
            startline = objItems(i - 1) + 2
            endline = objItems(i - 1) + objItems(i) + 1
            'MsgBox objKeys(i) & "start " & objItems(i - 1) + 1 & "end " & objItems(i - 1) + objItems(i)
        End If
        ActiveSheet.Rows(startline & ":" & endline).Select
        Selection.Copy    '选择复制某个关键字对应的区域
        Set Wb = Workbooks.Add(xlWBATWorksheet) '新建工作簿，写入数据
        With Wb.Sheets(1)
            .Name = objKeys(i)
            '.range("A1:J" & objItems(i))=temp
            '.Rows("A1:J" & objItems(i)).Select
            .Range("A1:J1") = bt '粘贴标题
            .Range("A2:J" & objItems(i)).PasteSpecial
            ActiveSheet.Paste    '粘贴数据
        End With
        Wb.SaveAs "C:\Users\Administrator\Desktop\" & objKeys(i) & k & ".xls" '保存工作簿到指定路径
        Wb.Close
    Next
    '
    End Sub

3.结果

    小数据量可行。文件过大可能会内存溢出，字典能承受的数据量可能有限,实用意义不是很大吧
    嫌麻烦可以下载一个 Excel文件切割器，不过好像80万的数据就崩溃了，也可能是我电脑带不起来吧。