DONT WANT TO "Rows to Repeat at top" on a condtion

[NimishK]

Hi Anyone

This could be quite challenging.

Have almost browsed through all the possible ideas of coding which i could not code of what i want but really wish to have great logic from you.

Kindly guide me so as to where to write the code in thisWorkbook or some other place

Basically I DONT WANT TO "Rows to Repeat at top" on a condtion.

Have attached the file for your reference.
https://www.dropbox.com/s/463fj7kv9a7uexo/Sample555-Sutures.xlsx?dl=0

here mydata Range refers to the items calculated from Row 15 onwards till the row which = "TOTAL" with additional Two rows and within column borders around

Kindly Print Preview
A. If you look at the file i have not coded but selected "Rows to Repeat at Top" = $14:$14 : Also scaled View to 85%

1. it comes correctly on Every Page
2. Now i would like to repeat the above condition with Coding
Condtion 1 : if mydata range i.e from row 15 to row 71 exceeds and falls into next page or pages in continuation then i want to "Rows to Repeat at Top " = $14:$14

Condition 2 : Suppose mydata range is from rows 15 to rows 57 with "TOTAL" at row 59 then I DONT WANT TO "Rows to Repeat at Top " = $14:$14
Eventhough datarange for Terms and Condtions have exceeded from 1st page onwards
Let me be also clear: Suppose if myData range exceeds more than 1 page or 2 pages then "Rows to Repeat " = $14:$14 but if the mydata Range ends in 2nd page then DONT WANT TO "Rows to Repeat" = $14:$14 on 3rd Page or more pages.

How to achieve the above result ?

Thanks
NimishK

 

[Worf]

From what I understood, you want each page to start with the title row, and the last column to the right should be the Total.
The conditions mentioned (wrapped text, merged cells) would disrupt the page layout, so page breaks should be moved to the appropriate positions, keeping wrapped text and merged cells.
Can you post a sample workbook where the issues are present and inform what the desired result is?

If this is not what you want, please explain…

 

[NimishK]

Worf


Here you have file attached without colour page break range as per the earlier code.
https://www.dropbox.com/s/ikyjbp9bn...rtPbreaks-WrappedMergeCells-Sutures.xlsm?dl=0

Merged cells start from row 15 in column A, B, and G for this File.
Wrapped Text in this file you will see in column D (because the lenght of values in column D MAY exceed the column width of column D and thats why its Wrapped for eg see sr no 3 Orthopaedic and its last item at row 39

Also you will see combination of wrapped text and merged cells from row 79 in this file

Sorry i forgot one important point of Orientation which should have been considered

With Activesheet.Pagesetup
        .Orientation = xlPortrait
        .Zoom = False      (Can We have automatic Zoom size as per the Data range) preferable 85 suits for this file
        .FitToPagesWide = 1
       .FitToPagesTall = 1
End With

When Normally Print Previewd the columns are seen from Column A to F.
PrintTitleRow of Row 14 showing in each Page.

When i executed the same with your code
error
in PrintPreview procedure

Do While Intersect(pag(i), r) Is Nothing INVALID PROCEDURE CALL OR ARGUEMENT

In short
1. Columns from A to H are to be seen (Fitting in Each PAge of Sheet)
2. Cells are Merged and Wrapped
3. PrintTitleRow or Rows to Repeat the 14th row i.e with the condition:
A) i.e 14th the header row to be seen from NextPage onwards till "TOTAL" is seen on its Last Page
and if data exceed after TOTAL with more pages then NO MORE 14th the Header Row
B) The Header Row to be displayed as per condtion A even if the data in the Range is Wrapped and Merged

 

[Worf]

- This version will adjust the vertical page break to column H, if necessary.
- Merged cells can throw errors, depending on where the code finds them. My testing was successful, but tell me what happens at your end.

Dim pag() As Range, ws As Worksheet


Sub PrintPreviewPages()                                                                 ' run this one
Dim r As Range, cp%, tp%, i%, section%, pp As Range, j%, oset%
Set ws = ActiveSheet
ws.PageSetup.Orientation = xlPortrait
ActiveWindow.View = xlNormalView
ActiveWindow.View = xlPageBreakPreview
If ws.VPageBreaks(1).Location.Column <> 9 Then Set ws.VPageBreaks(1).Location = [I1]
PageAddress2 False
Set r = ws.[d:d].Find("TOTAL", , xlValues)                                              ' total at column D
i = 1
Do While Intersect(pag(i), r) Is Nothing
    i = i + 1
    If i > 50 Then Exit Do
Loop
For j = 2 To i
    If pag(j).Find("Item Description", , xlValues) Is Nothing Then                      ' needs header
            oset = 0
            If WorksheetFunction.CountBlank(pag(j).Rows(1)) < pag(j).Columns.Count Then
                pag(j).Cells(1, 1).EntireRow.Insert                                     ' first row not empty
                oset = -1
            End If
            pag(1).Rows(14).Copy pag(j).Rows(1).Offset(oset)                            ' copy header
    End If
Next
PageAddress2 0                                                                          ' update array
Set pp = pag(1)
For j = 2 To UBound(pag)
    If Not BlankPage(pag(j)) Then Set pp = Union(pp, pag(j))
Next
pp.PrintPreview
End Sub


Sub PageAddress2(colorcode As Boolean)
Dim c%, v%, h%, cln%, rw%, hgth%, wth%, s$
c = 1: s = ""
ReDim pag(1 To (ws.VPageBreaks.Count + 1) * (ws.HPageBreaks.Count + 1))     'all pages on that sheet
For v = 0 To ws.VPageBreaks.Count
    For h = 0 To ws.HPageBreaks.Count
        If v = ws.VPageBreaks.Count Then
            wth = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
        Else
            wth = ws.VPageBreaks(v + 1).Location.Column - 1
        End If
        If h = ws.HPageBreaks.Count Then
            hgth = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
        Else
            hgth = ws.HPageBreaks(h + 1).Location.Row - 1
        End If
        If v = 0 Then
            cln = 1
        Else
            cln = ws.VPageBreaks(v).Location.Column
        End If
        If h = 0 Then
            rw = 1
        Else
            rw = ws.HPageBreaks(h).Location.Row
        End If
        Set pag(c) = Range(Cells(rw, cln).Address & ":" & Cells(hgth, wth).Address)     ' page address
        s = s & pag(c).Address & vbLf
        If colorcode Then pag(c).Interior.Color = RGB(CInt(250 * Rnd), CInt(250 * Rnd), CInt(250 * Rnd))
        c = c + 1
    Next
Next
'MsgBox s           ' all addresses
End Sub


Function BlankPage(p As Range) As Boolean
BlankPage = False
If WorksheetFunction.CountBlank(p) = p.Rows.Count * p.Columns.Count Then BlankPage = True
End Function

 

[NimishK]

Checked in excel 2007 works perfectly with below observations

pag(1).Rows(14).Copy pag(j).Rows(1).Offset(oset) ' copy header

It gives below error for above command

error 1004 "Cannot change part of Merged cell"

this only happens if the row(s) in that column is Wrapped

Else Everything works perfect if the row is single and not wrrapped though merged.

Found something intresting i really dont know if the below link could help us resolve the error of Merged Cell if wrapped whether you could throw your light
http://blog.contextures.com/archives/2012/06/07/autofit-merged-cell-row-height/

Presentation is always my concern.
Anticipating in future with Text wrapped in a row(s) with Merged cells unfortunately

 

[Worf]

New version:

Sub PrintPreviewPages()                                                                 ' run this one
Dim r As Range, cp%, tp%, i%, section%, pp As Range, j%, oset%
Set ws = ActiveSheet
ws.PageSetup.Orientation = xlPortrait
ActiveWindow.View = xlNormalView
ActiveWindow.View = xlPageBreakPreview
If ws.VPageBreaks(1).Location.Column <> 9 Then Set ws.VPageBreaks(1).Location = [I1]
PageAddress2 0
Set r = ws.[d:d].Find("TOTAL", , xlValues)                                              ' total at column D
i = 1
Do While Intersect(pag(i), r) Is Nothing
    i = i + 1
    If i > 50 Then Exit Do
Loop
For j = 2 To i
    If pag(j).Find("Item Description", , xlValues) Is Nothing Then                      ' needs header
            oset = 0
            If WorksheetFunction.CountBlank(pag(j).Rows(1)) < pag(j).Columns.Count Or pag(j).Cells(1, 1).MergeCells Then
                pag(j).Cells(1, 1).EntireRow.Insert                                     ' first row not empty or merged
                oset = -1
            End If
            pag(1).Rows(14).Copy pag(j).Rows(1).Offset(oset)                            ' copy header
            If ws.Cells(ws.HPageBreaks(j - 1).Location.Row - 1, 1) = "Sr. No" Then _
            ws.HPageBreaks(j - 1).Location = ws.Cells(ws.HPageBreaks(j - 1).Location.Row - 1, 1)    ' adjust break position
    End If
Next
PageAddress2 0                                                                          ' update array
Set pp = pag(1)
For j = 2 To UBound(pag)
    If Not BlankPage(pag(j)) Then Set pp = Union(pp, pag(j))
Next
pp.PrintPreview
End Sub

 

[NimishK]

pag(1).Rows(14).Copy pag(j).Rows(1).Offset(oset) ' copy header

Get Run time error 1004 Cannot Change Part of Merged cell for above

 

[Worf]

I used one of your sample workbooks for testing and it worked.

Can you post a link to your current file that throws this error?

 

[NimishK]

https://www.dropbox.com/s/x9pvyckl73di0ae/5025C.xlsm?dl=0

Above file throws error

 

[Worf]

Hi

- I was able to reproduce the error.
- The following code seems to eliminate it.
- However, bear in mind that merged cells will always be a potential source of trouble.
- If they are only serving aesthetic purposes, as opposed to functionality, note that you can achieve the same look without merging.

Sub PrintPreviewPages()                                                                 ' run this one
Dim r As Range, cp%, tp%, i%, section%, pp As Range, j%, rlr%, n%, bm_rng$, mtop$, wbr$, spoint%
Set ws = ActiveSheet
ws.PageSetup.Orientation = xlPortrait
ActiveWindow.View = xlNormalView
ActiveWindow.View = xlPageBreakPreview
If ws.VPageBreaks(1).Location.Column <> 9 Then Set ws.VPageBreaks(1).Location = [I1]
For n = 1 To ws.HPageBreaks.Count
    wbr = ws.HPageBreaks(n).Location.Address
    bm_rng = Cells(Range(wbr).Row, 1).MergeArea.Address
    spoint = InStr(1, bm_rng, ":", vbBinaryCompare)
    Select Case spoint > 0
        Case True
            mtop = Left(bm_rng, spoint - 1)
        Case False
            mtop = bm_rng
    End Select
    If Not wbr = mtop Then
        ws.HPageBreaks(n).Delete
        ws.HPageBreaks.Add Before:=Range(mtop)
    End If
Next
PageAddress2 0
Set r = ws.[d:d].Find("TOTAL", , xlValues)                                              ' total at column D
i = 1
Do While Intersect(pag(i), r) Is Nothing
    i = i + 1
    If i > 50 Then Exit Do
Loop
For j = 2 To i
    If pag(j).Find("Item Description", , xlValues) Is Nothing Then                      ' needs header
            Select Case pag(j).Cells(1, 1).MergeCells
                Case True
                    rlr = pag(j).Cells(1, 1).Row
                    ws.Cells(rlr, 1).EntireRow.Insert
                    pag(1).Rows(14).Copy ws.Cells(rlr, 1).Rows(1)
                    ws.Cells(rlr - 1, 1).Activate
                    ws.HPageBreaks(j - 1).Delete
                    ws.HPageBreaks.Add ws.Range("a" & rlr - 1)
                Case False
                    If WorksheetFunction.CountBlank(pag(j).Rows(1)) < pag(j).Columns.Count Then _
                        pag(j).Cells(1, 1).EntireRow.Insert
                    rlr = pag(j).Rows(1).Row
                    pag(1).Rows(14).Copy pag(j).Rows(1)
            End Select
    End If
Next
Application.ScreenUpdating = 1
PageAddress2 0                                                                          ' update array
Set pp = pag(1)
For j = 2 To UBound(pag)
    If Not BlankPage(pag(j)) Then Set pp = Union(pp, pag(j))
Next
pp.PrintPreview
End Sub

 

[NimishK]

Thanks

ws.HPageBreaks.Delete

run time error 1004 : Application- defined error or Object-defined error.

Ok with code above Can i acheive the same look without merging. If not with above code then how?