Question

我的VBA脚本正在从Sheet1范围A15，B15，J15，R360收集所有正确的数据，然后将其设置为Sheet2行A122，B122，C122，D122。分页后，它将使用范围（A1：R360）Sheet1中的所有列行创建Page1，Page2，Page3，我只需要在Page1，Page2，Page3上设置Sheet1的范围A15，B15，J15，R360。任何特别的评论，积极的反馈都将受到任何大师向导的赞赏。

我的脚本代码：

Sub AddHorizontalAlignment()

Dim LastRow As Long
Dim Sheet2 As Worksheet
Dim Unit As Integer
Dim HPB As HPageBreak
Dim RW As Long
Dim PageNum As Long
Dim Asheet As Worksheet
Dim Nsheet As Worksheet
Dim Acell As Range


Set Results = Sheets("Sheet2")
LastRow = Results.Cells(Results.Rows.Count, "Z").End(xlUp).Row

Range("A18:A50").Copy
Results.Range("A" & LastRow + 121).PasteSpecial xlValues
Range("B18:B50").Copy
Results.Range("B" & LastRow + 121).PasteSpecial xlValues
Range("J18:J50").Copy
Results.Range("C" & LastRow + 121).PasteSpecial xlValues
Range("R18:R50").Copy
Results.Range("D" & LastRow + 121).PasteSpecial xlValues

Application.DataEntryMode = False
Set Asheet = ActiveSheet

If Asheet.HPageBreaks.Count = 0 Then
    MsgBox "There are no HPageBreaks"
    Exit Sub
End If

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set Acell = Range("A1")



  Application.Goto Asheet.Range("A" & Rows.Count), True

RW = 1
PageNum = 1

For Each HPB In Asheet.HPageBreaks



With Asheet.Parent
        Set Nsheet = Worksheets.Add(after:=.Sheets(.Sheets.Count))
    End With

    'Give the sheet a name
    On Error Resume Next
    Nsheet.Name = "Page " & PageNum
    If Err.Number > 0 Then
        MsgBox "Change the name of : " & Nsheet.Name & " manually"
        Err.Clear
    End If
    On Error GoTo 0


With Asheet
        .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "S")).Copy _
                Nsheet.Cells(1)
    End With

 RW = HPB.Location.Row
    PageNum = PageNum + 1
Next HPB

Asheet.DisplayPageBreaks = False
Application.Goto Acell, True

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

对齐每个水平PageBreak的单独的工作表

0 个答案: