时间戳

首页 > 解决方案 > 如何在所有工作表中保持页眉（不是静态页眉）相同？

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

问题描述

我在 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

该宏运行良好，但我想知道如何将页眉保留在宏创建的所有新工作表中。有人可以在这里帮忙吗？

先感谢您！

标签： excelvba

解决方案

这可以变得更健壮，但我会将标题抓取到一个数组中，将正文抓取到另一个数组中。

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, only 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

推荐阅读