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