有序提取行数据到工作表的问题

quqiyuan

代码如下。。。
Sub test()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet0")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    arr = sht.[a1].Resize(r, 6)
    For Each sh In wb.Sheets    '先清除没用工作表
        If sh.Name <> sht.Name Then sh.Delete
    Next
    For i = 1 To 49
        ReDim brr(1 To 10000, 1 To 6)
        n = 0
        For j = 1 To UBound(arr)
            If arr(j, 2) = i Then
                n = n + 1
                For k = 1 To 6
                    brr(n, k) = arr(j, k)
                Next
            End If
        Next
        With Worksheets.Add(after:=wb.Sheets(Worksheets.Count))
            .Name = "Sheet" & i
            .[a1].Resize(n, 6) = brr
        End With
    Next
    Beep
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub