excel - 如何在所有工作表中保持页眉(不是静态页眉)相同？

Question

我在 Excel 中创建了一个宏，它将在 Excel 中复制一个表格，并将行除以我确定的特定数字(默认 = 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