VBA-批量数据分类

1.近期做了一个将总表数据按一定的分类规则来拆分成几个分表的自动表格，数据源不便公布，在这里只发布代码，仅供参考：

Sub classfication()
    Dim w0 As Workbook
    Dim w1 As Workbook
    Dim sheet1 As Worksheet
    Dim r0 As Range
    Dim r1 As Range
    Dim filename As String
    Dim rw()
    Dim arr1()
    Dim r()
    Dim classname
    Dim k
    Dim i As Long, j As Long
    Set classname = CreateObject("Scripting.Dictionary")
    Set w0 = ActiveWorkbook
    Set sheet1 = w0.Worksheets("总表")
    Set r1 = sheet1.UsedRange
    Set r0 = r1.Resize(1, r1.Columns.Count)
    r = r0
    arr1 = r1
    '读取分类信息
    For i = 2 To UBound(arr1, 1)
        k = arr1(i, 1)
        classname(k) = classname(k) + 1
    Next i
    filename = ThisWorkbook.Path & "\" & "分表.xlsx"
    createbook (filename)
    Set w1 = ActiveWorkbook
    For Each k In classname.keys
        crestesheet w1, k, r
    Next k
    For i = 2 To UBound(arr1, 1)
        rw = r1.Resize(1, r1.Columns.Count).Offset(i - 1, 0)
        Set r0 = w1.Worksheets(arr1(i, 1)).UsedRange
        r0.Resize(1, r0.Columns.Count).Offset(r0.Rows.Count, 0) = rw
    Next i
    changetype w1
    w1.Close
End Sub
'创建工作薄
Sub createbook(filename As String)
    If Dir(filename) = "" Then
        Workbooks.Add
    Else
        Kill filename
        Workbooks.Add
    End If
    ActiveWorkbook.SaveAs filename
End Sub
'创建表
Sub crestesheet(w1 As Workbook, classname, r)
    w1.Sheets.Add Worksheets(Worksheets.Count), , 1, xlWorksheet
    ActiveSheet.Name = classname
    ActiveSheet.Cells(1, 1).Resize(1, UBound(r, 2)) = r
End Sub
'修改表格格式
Sub changetype(w As Workbook)
    Dim sheetw As Worksheet, r As Range
    For Each sheetw In w.Worksheets
        Set r = sheetw.UsedRange
        With r
            .Borders.LineStyle = xlHairline
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    Next sheetw
End Sub