Solved: vba : Syntax modification help required

[satish gubbi]

Hi
I have below code which creates separate sheets at each manual page break, i need to add/modify this code, which creates sheet along with the first row repeating in all the sheets generated in other words specified row should repeat in all the sheets generated (as a headings)

And Also while copying the data code should transpose the values from rows to column

kindly help


Sub Create_Separate_Sheet_For_Each_HPageBreak()
Dim HPB As HPageBreak
Dim RW As Long
Dim PageNum As Long
Dim Asheet As Worksheet
Dim Nsheet As Worksheet
Dim Acell As Range

'Sheet with the data, you can also use Sheets("Sheet1")
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

'When the macro is ready we return to this cell on the ActiveSheet
Set Acell = Range("A1")

'Because of this bug we select a cell below your data
Application.Goto Asheet.Range("A" & Rows.Count), True

RW = 1
PageNum = 1

For Each HPB In Asheet.HPageBreaks
If HPB.Type = xlPageBreakManual Then
'Add a sheet for the page
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

'Copy the cells from the page into the new sheet
With Asheet
.Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy _
Nsheet.Cells(1)
End With
' If you want to make values of your formulas use this line also
' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value

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

Asheet.DisplayPageBreaks = False
Application.Goto Acell, True

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

[Bob Phillips]

Sub Create_Separate_Sheet_For_Each_HPageBreak()
Dim HPB As HPageBreak
Dim RW As Long
Dim PageNum As Long
Dim Asheet As Worksheet
Dim Acell As Range

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 = Asheet.Range("A1")

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

RW = 1
PageNum = 1

For Each HPB In Asheet.HPageBreaks

If HPB.Type = xlPageBreakManual Then

Call CreateAndCopy(Asheet, PageNum, RW, HPB.Location.Row)

RW = HPB.Location.Row

PageNum = PageNum + 1
End If
Next HPB

'pick up remaining page
Call CreateAndCopy(Asheet, PageNum, RW, Asheet.Cells(Asheet.Rows.Count, "A").End(xlUp).Row)

Asheet.DisplayPageBreaks = False
Application.Goto Acell, True

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


Private Function CreateAndCopy( _
ByRef source As Worksheet, _
ByVal PageNum As Long, _
ByVal StartNum As Long, _
ByVal EndRow As Long) As Boolean
Dim Nsheet As Worksheet

With source.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 source

.Range(.Cells(StartNum, "A"), .Cells(EndRow - 1, "K")).Copy _
Nsheet.Cells(1)
End With

If PageNum > 1 Then

source.Rows(1).Copy
Nsheet.Range("A1").Insert shift:=xlDown
End If
End Function

[satish gubbi]

This code worked amazingly

thank you very much for your support
regards,
Satish Gubbi