20170707xlVBA多区域拆分多表保持行高列宽

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

　　

转载于:https://www.cnblogs.com/nextseven/p/7130439.html