VBA -> Printing trouble .. or rather page setup

Hi cal,

You can either see the whole discussion: http://www.experts-exchange.com/jsp/qShow.jsp?ta=msoffice&qid=10308035

or, the bulk of the code was:


The following code will insert a subtotal at the bottom of each page, a blank row and a carried forward
subtotal on each subsequent page, and a grand total two cells below the final value in column B.  After
completing the print, it will also delete the inserted rows.  This code will run if your data is set
out as you previously provided i.e. Column A contains customer details, Column B contains Numeric data
for totalling.

If yoru sheet name is not Sheet1, then you will need to change those references in the code below.

It runs at around 3-4 seconds a page on my 400.  There are no doubt quicker ways to do this, however
this method is functional.

Sorry took a while to get back to you - have a lot on at present, and probably bit off more than I should
have.


Sub PrintSubTotals()

' Init looping variable
Counter = 1

Application.ScreenUpdating = False

' Refresh page breaks and clear print areas
ActiveSheet.ResetAllPageBreaks
ActiveSheet.PageSetup.PrintArea = ""

' Loop for processing
While Worksheets("Sheet1").Cells(CStr(Counter + 1), 2).Value > 0


  ' Test if the current row + 1 has page break marker and next row in
  ' column B is not empty
  If Worksheets("Sheet1").Rows(Counter + 2).PageBreak <> xlNone And _
        Range("B" & Counter + 1).Value > 0 Then
     ' Select rows 1 either before and two after break, and insert three new rows
     Rows((Counter + 1) & ":" & (Counter + 3)).Select
     Selection.Insert Shift:=xlDown
   
     ' Show "Sub Total" in bottom of column A
     Cells(Counter + 1, 1).Select
     Cells(Counter + 1, 1).Value = "Sub Total"
     Selection.Font.Bold = True
   
     ' Set value to Sum This Page in column B
     Cells(Counter + 1, 2).Select
     ActiveCell.FormulaR1C1 = "=Sum(R[" & CStr(-Counter) & "]C2:R[-1]C2)"
   
     ' Format the SubTotal and CF cells
     Range("B" & Counter + 1).Select
     Selection.Font.Bold = True
        With Selection.Borders(xlEdgeTop)
           .LineStyle = xlContinuous
           .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
           .LineStyle = xlContinuous
           .Weight = xlThin
        End With
     
     Range("B" & Counter + 3).Select
     Selection.Font.Bold = True
     With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
     End With
     With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
     End With
   
     ' Show "Carried Forward" in Column A
     Cells(Counter + 3, 1).Select
     Cells(Counter + 3, 1).Value = "Carry Fwd."
     Selection.Font.Bold = True
   
     ' Set carry forward formula
     Cells(Counter + 3, 2).Select
     ActiveCell.FormulaR1C1 = "=(R[-2]C)"
   
     ' Refresh Page Breaks
     ActiveSheet.ResetAllPageBreaks
     ActiveSheet.PageSetup.PrintArea = ""
   
     ' Increment counter to skip the inserted blank row
     Counter = Counter + 1
   
     ' Keep track of position of last subtotal for Grand Total
     LastSub = Counter
   
  End If
 
  ' Inc counter for next in loop
  Counter = Counter + 1
Wend

' Select next empty cell in B, and insert Grand Total amount
Range("B" & Counter + 2).Select
ActiveCell.FormulaR1C1 = "=Sum(R[" & CStr(-(Counter - LastSub)) & _
                                                  "]C2:R[-1]C2)"
                                                 
' Format Grand Total cell
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   With Selection.Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .Weight = xlMedium
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .Weight = xlMedium
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .Weight = xlMedium
       .ColorIndex = xlAutomatic
   End With
   With Selection.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .Weight = xlMedium
       .ColorIndex = xlAutomatic
   End With
 
' Provide text and format
Cells(Counter + 2, 1).Value = "Grand Total"
Range("A" & (Counter + 2) & ":B" & Counter + 2).Select
Selection.Font.Bold = True

'ActiveWindow.SelectedSheets.PrintOut Copies:=1



' Processing loop to remove inserted rows
For DeleteCounter = 1 To Counter

  If Range("A" & (DeleteCounter + 1)).Value = "Sub Total" Or _
     Range("A" & (DeleteCounter + 1)).Value = "Grand Total" Then
        Rows(DeleteCounter + 1 & ":" & DeleteCounter + 3).Select
        Selection.Delete Shift:=xlUp
  End If

Next

Application.ScreenUpdating = True

End Sub



There may be something of use - particularly if you can avoid relying on XL auto break points.


Also, while you are round, did you see this one:

http://www.experts-exchange.com/jsp/qManageQuestion.jsp?ta=msoffice&qid=20299458


Dave