我在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
该宏运行正常,但是我想知道如何在该宏创建的所有新表中保留页眉。有人可以在这里帮忙吗?
谢谢你!
这可以变得更健壮,但是我可以将头文件抓到一个数组中,将主体抓到另一个数组中。
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