如何在所有工作表中保持页眉(非静态页眉)相同?

问题描述 投票:3回答:1

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

该宏运行正常,但是我想知道如何在该宏创建的所有新表中保留页眉。有人可以在这里帮忙吗?

谢谢你!

excel vba
1个回答
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
© www.soinside.com 2019 - 2024. All rights reserved.