Как сохранить заголовок (не заголовок c) одинаковым на всех листах?

Question

Я создал макрос в Excel, который будет копировать таблицу в Excel и делить строки на определенное мной число c (по умолчанию = 500 строк) и открывать разные листы для каждого деления созданного макроса.

Используемый код:

Sub CopyTable()

    'Set dimensions
    Dim Table As Range, TableArray(), _
        CutValue As Integer, Cntr As Integer, _
        TempArray(), Width As Integer, _
        x As Integer, y As Integer, _
        Height As Long, Rep As Integer, _
        LoopReps As Long

    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=500)
    Width = Table.Columns.Count
    Height = Table.Rows.Count

    'Write to array
    TableArray = Table
    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CutValue

    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CutValue < CutValue Then _
            LoopReps = Height - Cntr * CutValue

        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CutValue, x)
            Next y
        Next x

        Worksheets.Add
        Range("A1").Resize(LoopReps, Width) = TempArray
    Next Cntr
End Sub

Этот макрос работает отлично, но я хотел бы знать, как сохранить заголовок во всех новых листах, созданных макросом. Кто-нибудь может помочь здесь?

Заранее спасибо!

Answer 1

Это можно сделать более надежным, но я бы взял заголовки в один массив, а тело - в другой.

Sub CopyTable()

    'Set dimensions
    Dim Table As Range, TableArray(), HeaderArray(), _
        CutValue As Long, Cntr As Long, _
        TempArray(), Width As Long, _
        x As Long, y As Long, _
        Height As Long, Rep As Long, _
        LoopReps As Long

    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=500)

    With Table
        Width = .Columns.Count
        Height = .Rows.Count - 1 'ignore headers

        HeaderArray = .Rows(1).Value
        TableArray = .Rows(2).Resize(Height).Value
    End With

    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CutValue

    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CutValue < CutValue Then _
            LoopReps = Height - Cntr * CutValue

        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CutValue, x)
            Next y
        Next x

        Dim ws As Worksheet
        Set ws = ThisWorkbook.Worksheets.Add

        ws.Range("A1").Resize(, Width).Value = HeaderArray
        ws.Range("A2").Resize(LoopReps, Width) = TempArray
    Next Cntr
End Sub

Мысли о том, как сделать это более устойчивым:

• Проверьте, не отменено ли поле ввода
• Проверьте, выбрано ли более одной строки
• Проверьте, имеет ли выделение только одну область (то есть не что-то вроде A1:C10,E1:F10, только A1:C10 )

РЕДАКТИРОВАТЬ :

Если вы хотите создать новые рабочие книги вместо этого, вы можете сделать что-то вроде следующего:

Dim wb as Workbook
Set wb = Workbooks.Add

With wb.Worksheets(1)
    .Range("A1").Resize(, Width).Value = HeaderArray
    .Range("A2").Resize(LoopReps, Width) = TempArray
End With