J
Janis
I accidentally marked the other thread answered and it is getting urgent.
I apologize for any unnecessary confusing.
In the code I pasted in the thread I had some code that was commented out
but I accidentally uncommented and it WAS CONFUSING. Sorry. I tested the
code below over and over with the suggestions ONLY that are commented in
below by JOel and Jim.
I tried them in all combinations. The first suggestion by Jim doesn't
change anything. The second suggestion by Joel doesn't change anything
either. I get a runtime error 9 subscript out of range at the line marked in
asterisks in any case.
There are about 12 pagebreaks in this sheet. I am getting some screen
redraw problems when I run this sometimes. Do I need a better graphics
monitor? I don't know what to check.
tia,
------------entire code -----
Sub VOD_11x17_Page_Setup()
'This is the new page set up without column B for sheets >+ VOD_v2.
Dim x As Integer
Dim I As Integer
Dim K As Integer
Dim J As String
Dim C As Range
Dim PageNumber As Long
Dim SubTotalRow As Long
Dim Test As Boolean
Dim Row1 As Integer
Dim AC_Sheet As Worksheet
Dim AW As Workbook
Dim AW_Name As String
Dim UsedRange1 As Range
Dim UsedRows1 As Long
Dim UsedCol1 As Long
Dim SubTotalRows As Variant
Dim RowsPerPage As Long
Application.ActiveSheet.UsedRange
Set AC_Sheet = Application.ActiveSheet
Set AW = Application.ActiveWorkbook
AW_Name = AW.name
Set UsedRange1 = AC_Sheet.UsedRange
UsedRows1 = UsedRange1.Rows.Count
UsedCol1 = UsedRange1.Columns.Count
SubTotalRows = GetSubTotalRows()
Application.ActivePrinter = "\\martinezfs1-bay\CA-Martinez-94C on Ne02:"
PS411x17
Application.ScreenUpdating = False
With ActiveSheet.PageSetup
.PrintArea = ""
.PrintTitleRows = "$1:$11"
.PrintTitleColumns = ""
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 99
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.DisplayPageBreaks = True
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.ResetAllPageBreaks
ActiveWindow.View = xlNormalView
x = ActiveSheet.HPageBreaks.Count
'RowsPerPage = ActiveSheet.HPageBreaks(2).Location.Row -
ActiveSheet.HPageBreaks(1).Location.Row
With ActiveSheet.HPageBreaks 'added by Tomlinson
**** RowsPerPage = .Item(2).Location.Row - .Item(1).Location.Row****
End With
K = 1
PageNumber = 1
Row1 = 0
For I = 0 To UBound(SubTotalRows)
SubTotalRow = SubTotalRows(I)
If Row1 = 0 Then
Row1 = ActiveSheet.HPageBreaks(PageNumber).Location.Row
End If
If SubTotalRow > Row1 Then
ActiveWindow.SelectedSheets.HPageBreaks.Add
Before:=Cells(SubTotalRows(I - 1) + 1, 1)
Row1 = SubTotalRows(I - 1) + RowsPerPage
PageNumber = PageNumber + 1
End If
' If SubTotalRow > Row1 Then 'added by Joel
' Set ActiveSheet.HPageBreaks(PageNumber).Location =
Cells(SubTotalRows(I - 1) + 1, 1)
' Row1 = SubTotalRows(I - 1) + RowsPerPage
' PageNumber = PageNumber + 1
' End If
Next I
Application.ScreenUpdating = True
ActiveWindow.View = xlNormalView
Range(FirstDataCell).Activate
Range("A1").Activate
End Sub
-------------two called functions---------------------
Private Function GetSubTotalRows()
Dim UsedRange1 As Range
Dim Rows() As Variant
Dim I As Long
Dim UsedCol1 As Long
Dim C As Range
Set UsedRange1 = Intersect(Range(ServiceGroupColumn & FirstDataRow & ":" &
ServiceGroupColumn & ActiveSheet.UsedRange.Rows.Count), ActiveSheet.UsedRange)
Set UsedRange1 = UsedRange1.SpecialCells(xlCellTypeBlanks)
UsedCol1 = UsedRange1.Columns.Count
I = 0
For Each C In UsedRange1
If IsSubTotalRow(C.Row, UsedCol1) = True Then
ReDim Preserve Rows(I)
Rows(I) = C.Row
I = I + 1
End If
Next C
GetSubTotalRows = Rows()
End Function
Private Function IsSubTotalRow(ByVal I As Integer, ByVal x As Integer) As
Boolean
Dim C As Range
Dim Value2 As Variant
IsSubTotalRow = True
For Each C In Range(Cells(I, 1), Cells(I, x))
'C.Select
Value2 = CStr(C.Value2)
If Left(C.Formula, 6) <> "=SUMIF" Then
If CStr(C.Value2) <> "" Then
IsSubTotalRow = False
End If
End If
Next C
End Function
I apologize for any unnecessary confusing.
In the code I pasted in the thread I had some code that was commented out
but I accidentally uncommented and it WAS CONFUSING. Sorry. I tested the
code below over and over with the suggestions ONLY that are commented in
below by JOel and Jim.
I tried them in all combinations. The first suggestion by Jim doesn't
change anything. The second suggestion by Joel doesn't change anything
either. I get a runtime error 9 subscript out of range at the line marked in
asterisks in any case.
There are about 12 pagebreaks in this sheet. I am getting some screen
redraw problems when I run this sometimes. Do I need a better graphics
monitor? I don't know what to check.
tia,
------------entire code -----
Sub VOD_11x17_Page_Setup()
'This is the new page set up without column B for sheets >+ VOD_v2.
Dim x As Integer
Dim I As Integer
Dim K As Integer
Dim J As String
Dim C As Range
Dim PageNumber As Long
Dim SubTotalRow As Long
Dim Test As Boolean
Dim Row1 As Integer
Dim AC_Sheet As Worksheet
Dim AW As Workbook
Dim AW_Name As String
Dim UsedRange1 As Range
Dim UsedRows1 As Long
Dim UsedCol1 As Long
Dim SubTotalRows As Variant
Dim RowsPerPage As Long
Application.ActiveSheet.UsedRange
Set AC_Sheet = Application.ActiveSheet
Set AW = Application.ActiveWorkbook
AW_Name = AW.name
Set UsedRange1 = AC_Sheet.UsedRange
UsedRows1 = UsedRange1.Rows.Count
UsedCol1 = UsedRange1.Columns.Count
SubTotalRows = GetSubTotalRows()
Application.ActivePrinter = "\\martinezfs1-bay\CA-Martinez-94C on Ne02:"
PS411x17
Application.ScreenUpdating = False
With ActiveSheet.PageSetup
.PrintArea = ""
.PrintTitleRows = "$1:$11"
.PrintTitleColumns = ""
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 99
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.DisplayPageBreaks = True
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.ResetAllPageBreaks
ActiveWindow.View = xlNormalView
x = ActiveSheet.HPageBreaks.Count
'RowsPerPage = ActiveSheet.HPageBreaks(2).Location.Row -
ActiveSheet.HPageBreaks(1).Location.Row
With ActiveSheet.HPageBreaks 'added by Tomlinson
**** RowsPerPage = .Item(2).Location.Row - .Item(1).Location.Row****
End With
K = 1
PageNumber = 1
Row1 = 0
For I = 0 To UBound(SubTotalRows)
SubTotalRow = SubTotalRows(I)
If Row1 = 0 Then
Row1 = ActiveSheet.HPageBreaks(PageNumber).Location.Row
End If
If SubTotalRow > Row1 Then
ActiveWindow.SelectedSheets.HPageBreaks.Add
Before:=Cells(SubTotalRows(I - 1) + 1, 1)
Row1 = SubTotalRows(I - 1) + RowsPerPage
PageNumber = PageNumber + 1
End If
' If SubTotalRow > Row1 Then 'added by Joel
' Set ActiveSheet.HPageBreaks(PageNumber).Location =
Cells(SubTotalRows(I - 1) + 1, 1)
' Row1 = SubTotalRows(I - 1) + RowsPerPage
' PageNumber = PageNumber + 1
' End If
Next I
Application.ScreenUpdating = True
ActiveWindow.View = xlNormalView
Range(FirstDataCell).Activate
Range("A1").Activate
End Sub
-------------two called functions---------------------
Private Function GetSubTotalRows()
Dim UsedRange1 As Range
Dim Rows() As Variant
Dim I As Long
Dim UsedCol1 As Long
Dim C As Range
Set UsedRange1 = Intersect(Range(ServiceGroupColumn & FirstDataRow & ":" &
ServiceGroupColumn & ActiveSheet.UsedRange.Rows.Count), ActiveSheet.UsedRange)
Set UsedRange1 = UsedRange1.SpecialCells(xlCellTypeBlanks)
UsedCol1 = UsedRange1.Columns.Count
I = 0
For Each C In UsedRange1
If IsSubTotalRow(C.Row, UsedCol1) = True Then
ReDim Preserve Rows(I)
Rows(I) = C.Row
I = I + 1
End If
Next C
GetSubTotalRows = Rows()
End Function
Private Function IsSubTotalRow(ByVal I As Integer, ByVal x As Integer) As
Boolean
Dim C As Range
Dim Value2 As Variant
IsSubTotalRow = True
For Each C In Range(Cells(I, 1), Cells(I, x))
'C.Select
Value2 = CStr(C.Value2)
If Left(C.Formula, 6) <> "=SUMIF" Then
If CStr(C.Value2) <> "" Then
IsSubTotalRow = False
End If
End If
Next C
End Function