Public Sub 多个区域拆分到多表()

    AppSettings

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant

    StartTime = VBA.Timer

    'Input code here

    Dim Wb As Workbook

    Dim sht As Worksheet

    Dim OneSht As Worksheet

    Const ROW_COUNT As Long = 16

    Const COLUMN_COUNT As Long = 9

    Const PERSONS As Long = 85

    Set Wb = Application.ThisWorkbook

    Set sht = Wb.Worksheets("主表")

    Dim rh() As Double

    Dim cw() As Double

    With sht

        '保存模板的行高与列宽

        ReDim rh(1 To ROW_COUNT)

        ReDim cw(1 To COLUMN_COUNT)

        For i = 1 To ROW_COUNT

            rh(i) = .Cells(i, 1).RowHeight

        Next i

        For j = 1 To COLUMN_COUNT

            cw(j) = .Cells(1, j).ColumnWidth

        Next j

        For i = 1 To ROW_COUNT * PERSONS Step ROW_COUNT

            '预先删除

            On Error Resume Next

            Wb.Worksheets(.Cells(i + 3, 2).Value).Delete

            On Error GoTo 0

            '新建表格

            Set OneSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))

            OneSht.Name = .Cells(i + 3, 2).Value

            '复制区域

            .Cells(i, 1).Resize(ROW_COUNT, COLUMN_COUNT).Copy OneSht.Range("A1")

            '设置行高与列宽

            For m = 1 To ROW_COUNT

                OneSht.Rows(m).RowHeight = rh(m)

            Next m

            For n = 1 To COLUMN_COUNT

                OneSht.Columns(n).ColumnWidth = cw(n)

            Next n

        Next i

    End With

    UsedTime = VBA.Timer - StartTime

    Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")

ErrorExit:

    Set Wb = Nothing

    Set sht = Nothing

    Set OneSht = Nothing

    AppSettings False

    Exit Sub

ErrHandler:

    If Err.Number <> 0 Then

        MsgBox Err.Description & "！", vbCritical, "NextSeven "

        Debug.Print Err.Description

        Err.Clear

        Resume ErrorExit

    End If

End Sub

Public Sub AppSettings(Optional IsStart As Boolean = True)

    If IsStart Then

        Application.ScreenUpdating = False

        Application.DisplayAlerts = False

        Application.Calculation = xlCalculationManual

        Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"

    Else

        Application.ScreenUpdating = True

        Application.DisplayAlerts = True

        Application.Calculation = xlCalculationAutomatic

        Application.StatusBar = False

    End If

End Sub