ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Add line in existing macro to use template (https://www.excelbanter.com/excel-programming/404717-add-line-existing-macro-use-template.html)

Amy
Add line in existing macro to use template
 
I have a macro that splits one sheet with many pages into individual files by
page numbers using the horizontal page break. It works perfectly. However, I
need it to either A - include the header (and margins) from the original file
when saving to the new file or B - use a template for the new files. I have
tried to use the repeat rows from the first page but that makes a big mess in
the new file. I have copied the macro below. Thanks for the help.

Amy


Sub SplitPages()

Dim horzPBArray()
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim TopRow As Long
Dim i As Long

Set curWks = ActiveSheet
curWks.DisplayPageBreaks = False

ThisWorkbook.Names.Add Name:="hzPB", RefersToR1C1:="=GET.DOCUMENT(64,"""
& ActiveSheet.Name & """)"

ThisWorkbook.Names.Add Name:="vPB", RefersToR1C1:="=GET.DOCUMENT(65,"""
& ActiveSheet.Name & """)"

i = 1
While Not IsError(Evaluate("Index(hzPB," & i & ")"))
ReDim Preserve horzPBArray(1 To i)
horzPBArray(i) = Evaluate("Index(hzPB," & i & ")")
i = i + 1
Wend

ReDim Preserve horzPBArray(1 To i - 1)
Set newWks = Workbooks.Add(1).Worksheets(1)

TopRow = 1
For i = LBound(horzPBArray) To UBound(horzPBArray)
newWks.Cells.Clear
Columns("H:H").ColumnWidth = 13.29
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a1")
newWks.Parent.SaveAs Filename:="S:\Amy\Invoices\test\" & "Page" & i,
FileFormat:=xlWorkbookNormal
TopRow = horzPBArray(i)
Next i

newWks.Parent.Close SaveChanges:=False

End Sub

Amy
Add line in existing macro to use template
 
My impatience got the best of me... This group is so empowering! Just in case
anyone else could use the info, I have posted back what I figured out to get
everything to work!


Columns("H:H").ColumnWidth = 13.29
Columns("J:J").ColumnWidth = 4.5
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a14")
newWks.PageSetup.LeftHeaderPicture.Filename = "S:\Logo
Files\SHINElogoMed.jpg"
newWks.PageSetup.LeftHeader = "&G"
newWks.PageSetup.TopMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.HeaderMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.FooterMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.LeftMargin = Application.InchesToPoints(1)
newWks.PageSetup.RightMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.Zoom = 95

"Amy" wrote:

I have a macro that splits one sheet with many pages into individual files by
page numbers using the horizontal page break. It works perfectly. However, I
need it to either A - include the header (and margins) from the original file
when saving to the new file or B - use a template for the new files. I have
tried to use the repeat rows from the first page but that makes a big mess in
the new file. I have copied the macro below. Thanks for the help.

Amy


Sub SplitPages()

Dim horzPBArray()
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim TopRow As Long
Dim i As Long

Set curWks = ActiveSheet
curWks.DisplayPageBreaks = False

ThisWorkbook.Names.Add Name:="hzPB", RefersToR1C1:="=GET.DOCUMENT(64,"""
& ActiveSheet.Name & """)"

ThisWorkbook.Names.Add Name:="vPB", RefersToR1C1:="=GET.DOCUMENT(65,"""
& ActiveSheet.Name & """)"

i = 1
While Not IsError(Evaluate("Index(hzPB," & i & ")"))
ReDim Preserve horzPBArray(1 To i)
horzPBArray(i) = Evaluate("Index(hzPB," & i & ")")
i = i + 1
Wend

ReDim Preserve horzPBArray(1 To i - 1)
Set newWks = Workbooks.Add(1).Worksheets(1)

TopRow = 1
For i = LBound(horzPBArray) To UBound(horzPBArray)
newWks.Cells.Clear
Columns("H:H").ColumnWidth = 13.29
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a1")
newWks.Parent.SaveAs Filename:="S:\Amy\Invoices\test\" & "Page" & i,
FileFormat:=xlWorkbookNormal
TopRow = horzPBArray(i)
Next i

newWks.Parent.Close SaveChanges:=False

End Sub

Amy
Add line in existing macro to use template
 
Just in case anyone can use the information, I figured out exactly what I
needed!

Columns("H:H").ColumnWidth = 13.29
Columns("J:J").ColumnWidth = 4.5
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a14")
newWks.PageSetup.LeftHeaderPicture.Filename = "S:\Logo
Files\SHINElogoMed.jpg"
newWks.PageSetup.LeftHeader = "&G"
newWks.PageSetup.TopMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.HeaderMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.FooterMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.LeftMargin = Application.InchesToPoints(1)
newWks.PageSetup.RightMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.Zoom = 95

"Amy" wrote:

I have a macro that splits one sheet with many pages into individual files by
page numbers using the horizontal page break. It works perfectly. However, I
need it to either A - include the header (and margins) from the original file
when saving to the new file or B - use a template for the new files. I have
tried to use the repeat rows from the first page but that makes a big mess in
the new file. I have copied the macro below. Thanks for the help.

Amy


Sub SplitPages()

Dim horzPBArray()
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim TopRow As Long
Dim i As Long

Set curWks = ActiveSheet
curWks.DisplayPageBreaks = False

ThisWorkbook.Names.Add Name:="hzPB", RefersToR1C1:="=GET.DOCUMENT(64,"""
& ActiveSheet.Name & """)"

ThisWorkbook.Names.Add Name:="vPB", RefersToR1C1:="=GET.DOCUMENT(65,"""
& ActiveSheet.Name & """)"

i = 1
While Not IsError(Evaluate("Index(hzPB," & i & ")"))
ReDim Preserve horzPBArray(1 To i)
horzPBArray(i) = Evaluate("Index(hzPB," & i & ")")
i = i + 1
Wend

ReDim Preserve horzPBArray(1 To i - 1)
Set newWks = Workbooks.Add(1).Worksheets(1)

TopRow = 1
For i = LBound(horzPBArray) To UBound(horzPBArray)
newWks.Cells.Clear
Columns("H:H").ColumnWidth = 13.29
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a1")
newWks.Parent.SaveAs Filename:="S:\Amy\Invoices\test\" & "Page" & i,
FileFormat:=xlWorkbookNormal
TopRow = horzPBArray(i)
Next i

newWks.Parent.Close SaveChanges:=False

End Sub

Amy
Add line in existing macro to use template
 
Here is what I finally figured out... just in case anyone else can use the
info.




Columns("H:H").ColumnWidth = 13.29
Columns("J:J").ColumnWidth = 4.5
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a14")
newWks.PageSetup.LeftHeaderPicture.Filename = "S:\Logo
Files\SHINElogoMed.jpg"
newWks.PageSetup.LeftHeader = "&G"
newWks.PageSetup.TopMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.HeaderMargin = Application.InchesToPoints(0.08)
newWks.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.FooterMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.LeftMargin = Application.InchesToPoints(1)
newWks.PageSetup.RightMargin = Application.InchesToPoints(0.5)
newWks.PageSetup.Zoom = 95

"Amy" wrote:

I have a macro that splits one sheet with many pages into individual files by
page numbers using the horizontal page break. It works perfectly. However, I
need it to either A - include the header (and margins) from the original file
when saving to the new file or B - use a template for the new files. I have
tried to use the repeat rows from the first page but that makes a big mess in
the new file. I have copied the macro below. Thanks for the help.

Amy


Sub SplitPages()

Dim horzPBArray()
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim TopRow As Long
Dim i As Long

Set curWks = ActiveSheet
curWks.DisplayPageBreaks = False

ThisWorkbook.Names.Add Name:="hzPB", RefersToR1C1:="=GET.DOCUMENT(64,"""
& ActiveSheet.Name & """)"

ThisWorkbook.Names.Add Name:="vPB", RefersToR1C1:="=GET.DOCUMENT(65,"""
& ActiveSheet.Name & """)"

i = 1
While Not IsError(Evaluate("Index(hzPB," & i & ")"))
ReDim Preserve horzPBArray(1 To i)
horzPBArray(i) = Evaluate("Index(hzPB," & i & ")")
i = i + 1
Wend

ReDim Preserve horzPBArray(1 To i - 1)
Set newWks = Workbooks.Add(1).Worksheets(1)

TopRow = 1
For i = LBound(horzPBArray) To UBound(horzPBArray)
newWks.Cells.Clear
Columns("H:H").ColumnWidth = 13.29
curWks.Rows(TopRow & ":" & horzPBArray(i) - 1).Copy
Destination:=newWks.Range("a1")
newWks.Parent.SaveAs Filename:="S:\Amy\Invoices\test\" & "Page" & i,
FileFormat:=xlWorkbookNormal
TopRow = horzPBArray(i)
Next i

newWks.Parent.Close SaveChanges:=False

End Sub


All times are GMT +1. The time now is 04:11 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com