Custom Page Break for Last Page and Print Last page without Row Headers

hassanleo1987

Board Regular
Joined
Apr 19, 2017
Messages
56
Hi,

I have a multi-sheet file where I need custom page break based on pivot table refresh and last page of every sheet must be printed without repeated row headers.

Step-1: Change the date in Cell H2 and Refresh the pivot table. This will update the Data Table A5:I70 where are all cells are formulated from pivot table cache table. (Automatic calculation should be checked before this step in order to update the data table quickly)

Step-2: After refreshing the pivot table, check the formula blank rows at the end of data table and delete all the formula blank rows (marked "Delete row" here in the example), leaving last 2 rows of data table intact.

Step-3: The automatic page break will shift after deleting the formula blank rows. Check if the automatic page break is coming the in the fixed Range (A47:I63).

Step-4: If NO, then OK to save the file as PDF with current page setup / print area. (This way the fixed Range (A47:I63) comes nicely under the data table!)

Step-5: If YES, then move the last page break above ROW 47. remove the repeat row header only for the last page and save the file as PDF. (Since the actual data table will be a multipage setup).

As I have mentioned this is multisheet workbook but for the sake of example, here it is showing only one.

I can modify to added other sheets as required. because the step 2 ~ 5 will be repeated for next sheets and after the last specified sheet, an array of selected sheets wil be grouped and the file will be saved as PDF. (This I can handle myself!)

Please help with step 2 ~ 5 code!

Here is the example sheet.

Example TS.xlsx
ABCDEFGHIJKL
11
22Date :1-Oct
33
4ABCDEFGHIRow Labels
510abcabcabcabcabcabc10abc10
620abcabcabcabcabcabc20abc20
730abcabcabcabcabcabc30abc30
840abcabcabcabcabcabc40abc40
950abcabcabcabcabcabc50abc50
1060abcabcabcabcabcabc60abc60
1170abcabcabcabcabcabc70abc70
121170abcabcabcabcabcabc1170abc1170
131180abcabcabcabcabcabc1180abc1180
141190abcabcabcabcabcabc1190abc1190
151200abcabcabcabcabcabc1200abc1200
161210abcabcabcabcabcabc1210abc1210
171220abcabcabcabcabcabc1220abc1220
181230abcabcabcabcabcabc1230abc1230
191240abcabcabcabcabcabc1240abc1240
201250abcabcabcabcabcabc1250abc1250
211260abcabcabcabcabcabc1260abc1260
221270abcabcabcabcabcabc1270abc1270
231280abcabcabcabcabcabc1280abc1280
241290abcabcabcabcabcabc1290abc1290
251300abcabcabcabcabcabc1300abc1300
261310abcabcabcabcabcabc1310abc1310
271320abcabcabcabcabcabc1320abc1320
281330abcabcabcabcabcabc1330abc1330
291340abcabcabcabcabcabc1340abc1340
301350abcabcabcabcabcabc1350abc1350
311360abcabcabcabcabcabc1360abc1360
321370abcabcabcabcabcabc1370abc1370
331380abcabcabcabcabcabc1380abc1380
341390abcabcabcabcabcabc1390abc1390
351400abcabcabcabcabcabc1400abc1400
361410abcabcabcabcabcabc1410abc1410
371420abcabcabcabcabcabc1420abc1420
381430abcabcabcabcabcabc1430abc1430
391440abcabcabcabcabcabc1440abc1440
401450abcabcabcabcabcabc1450abc1450
411460abcabcabcabcabcabc1460abc1460
421470abcabcabcabcabcabc1470abc1470
43Delete Row
44Delete Row
45Delete Row
46Delete Row
47Delete Row
48Delete Row
49Delete Row
50Delete Row
51Delete Row
52Delete Row
53Delete Row
54Delete Row
55Delete Row
56Delete Row
57Delete Row
58Delete Row
59Delete Row
60Delete Row
61Delete Row
62Delete Row
63Delete Row
64Delete Row
65Delete Row
66Delete Row
67Delete Row
68Delete Row
69
70
71Total41200
72
73xyzxyzxyzxyzxyzxyzxyzxyzxyz
74xyzxyzxyzxyzxyzxyzxyzxyzxyz
75xyzxyzxyzxyzxyzxyzxyzxyzxyz
76xyzxyzxyzxyzxyzxyzxyzxyzxyz
77xyzxyzxyzxyzxyzxyzxyzxyzxyz
78xyzxyzxyzxyzxyzxyzxyzxyzxyz
79xyzxyzxyzxyzxyzxyzxyzxyzxyz
80xyzxyzxyzxyzxyzxyzxyzxyzxyz
81xyzxyzxyzxyzxyzxyzxyzxyzxyz
82xyzxyzxyzxyzxyzxyzxyzxyzxyz
83xyzxyzxyzxyzxyzxyzxyzxyzxyz
84xyzxyzxyzxyzxyzxyzxyzxyzxyz
85xyzxyzxyzxyzxyzxyzxyzxyzxyz
86xyzxyzxyzxyzxyzxyzxyzxyzxyz
87xyzxyzxyzxyzxyzxyzxyzxyzxyz
88xyzxyzxyzxyzxyzxyzxyzxyzxyz
89xyzxyzxyzxyzxyzxyzxyzxyzxyz
90
Sheet1
Cell Formulas
RangeFormula
H71H71=SUM(H5:H70)
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sorry, I can't help you with this.
Hope someone else can.
Example TS.xlsm
ABCDEFGHIJKL
11
22Date :1-Oct
33
4ABCDEFGHIRow Labels
510abcabcabcabcabcabc10abc10
620abcabcabcabcabcabc20abc20
730abcabcabcabcabcabc30abc30
840abcabcabcabcabcabc40abc40
950abcabcabcabcabcabc50abc50
1060abcabcabcabcabcabc60abc60
1170abcabcabcabcabcabc70abc70
121170abcabcabcabcabcabc1170abc1170
131180abcabcabcabcabcabc1180abc1180
141190abcabcabcabcabcabc1190abc1190
151200abcabcabcabcabcabc1200abc1200
161210abcabcabcabcabcabc1210abc1210
171220abcabcabcabcabcabc1220abc1220
181230abcabcabcabcabcabc1230abc1230
191240abcabcabcabcabcabc1240abc1240
201250abcabcabcabcabcabc1250abc1250
211260abcabcabcabcabcabc1260abc1260
221270abcabcabcabcabcabc1270abc1270
231280abcabcabcabcabcabc1280abc1280
241290abcabcabcabcabcabc1290abc1290
251300abcabcabcabcabcabc1300abc1300
261310abcabcabcabcabcabc1310abc1310
271320abcabcabcabcabcabc1320abc1320
281330abcabcabcabcabcabc1330abc1330
291340abcabcabcabcabcabc1340abc1340
301350abcabcabcabcabcabc1350abc1350
311360abcabcabcabcabcabc1360abc1360
321370abcabcabcabcabcabc1370abc1370
331380abcabcabcabcabcabc1380abc1380
341390abcabcabcabcabcabc1390abc1390
351400abcabcabcabcabcabc1400abc1400
361410abcabcabcabcabcabc1410abc1410
371420abcabcabcabcabcabc1420abc1420
381430abcabcabcabcabcabc1430abc1430
391440abcabcabcabcabcabc1440abc1440
401450abcabcabcabcabcabc1450abc1450
411460abcabcabcabcabcabc1460abc1460
421470abcabcabcabcabcabc1470abc1470
431470abcabcabcabcabcabc1470abc1470
441470abcabcabcabcabcabc1470abc1470
451470abcabcabcabcabcabc1470abc1470
461470abcabcabcabcabcabc1470abc1470
471470abcabcabcabcabcabc1470abc1470
481470abcabcabcabcabcabc1470abc1470
491470abcabcabcabcabcabc1470abc1470
501470abcabcabcabcabcabc1470abc1470
511470abcabcabcabcabcabc1470abc1470
521470abcabcabcabcabcabc1470abc1470
531470abcabcabcabcabcabc1470abc1470
541470abcabcabcabcabcabc1470abc1470
551470abcabcabcabcabcabc1470abc1470
561470abcabcabcabcabcabc1470abc1470
571470abcabcabcabcabcabc1470abc1470
581470abcabcabcabcabcabc1470abc1470
591470abcabcabcabcabcabc1470abc1470
601470abcabcabcabcabcabc1470abc1470
611470abcabcabcabcabcabc1470abc1470
621470abcabcabcabcabcabc1470abc1470
631470abcabcabcabcabcabc1470abc1470
641470abcabcabcabcabcabc1470abc1470
651470abcabcabcabcabcabc1470abc1470
661470abcabcabcabcabcabc1470abc1470
671470abcabcabcabcabcabc1470abc1470
681470abcabcabcabcabcabc1470abc1470
691470abcabcabcabcabcabc1470abc1470
701470abcabcabcabcabcabc1470abc1470
711470abcabcabcabcabcabc1470abc1470
721470abcabcabcabcabcabc1470abc1470
731470abcabcabcabcabcabc1470abc1470
741470abcabcabcabcabcabc1470abc1470
751470abcabcabcabcabcabc1470abc1470
761470abcabcabcabcabcabc1470abc1470
771470abcabcabcabcabcabc1470abc1470
781470abcabcabcabcabcabc1470abc1470
791470abcabcabcabcabcabc1470abc1470
801470abcabcabcabcabcabc1470abc1470
811470abcabcabcabcabcabc1470abc1470
821470abcabcabcabcabcabc1470abc1470
831470abcabcabcabcabcabc1470abc1470
841470abcabcabcabcabcabc1470abc1470
851470abcabcabcabcabcabc1470abc1470
861470abcabcabcabcabcabc1470abc1470
871470abcabcabcabcabcabc1470abc1470
881470abcabcabcabcabcabc1470abc1470
891470abcabcabcabcabcabc1470abc1470
901470abcabcabcabcabcabc1470abc1470
911470abcabcabcabcabcabc1470abc1470
921470abcabcabcabcabcabc1470abc1470
931470abcabcabcabcabcabc1470abc1470
941470abcabcabcabcabcabc1470abc1470
951470abcabcabcabcabcabc1470abc1470
961470abcabcabcabcabcabc1470abc1470
971470abcabcabcabcabcabc1470abc1470
981470abcabcabcabcabcabc1470abc1470
991470abcabcabcabcabcabc1470abc1470
1001470abcabcabcabcabcabc1470abc1470
1011470abcabcabcabcabcabc1470abc1470
1021470abcabcabcabcabcabc1470abc1470
1031470abcabcabcabcabcabc1470abc1470
1041470abcabcabcabcabcabc1470abc1470
1051470abcabcabcabcabcabc1470abc1470
1061470abcabcabcabcabcabc1470abc1470
1071470abcabcabcabcabcabc1470abc1470
1081470abcabcabcabcabcabc1470abc1470
1091470abcabcabcabcabcabc1470abc1470
1101470abcabcabcabcabcabc1470abc1470
1111470abcabcabcabcabcabc1470abc1470
1121470abcabcabcabcabcabc1470abc1470
1131470abcabcabcabcabcabc1470abc1470
1141470abcabcabcabcabcabc1470abc1470
1151470abcabcabcabcabcabc1470abc1470
1161470abcabcabcabcabcabc1470abc1470
1171470abcabcabcabcabcabc1470abc1470
1181470abcabcabcabcabcabc1470abc1470
1191470abcabcabcabcabcabc1470abc1470
1201470abcabcabcabcabcabc1470abc1470
1211470abcabcabcabcabcabc1470abc1470
1221470abcabcabcabcabcabc1470abc1470
1231470abcabcabcabcabcabc1470abc1470
1241470abcabcabcabcabcabc1470abc1470
1251470abcabcabcabcabcabc1470abc1470
1261470abcabcabcabcabcabc1470abc1470
1271470abcabcabcabcabcabc1470abc1470
1281470abcabcabcabcabcabc1470abc1470
1291470abcabcabcabcabcabc1470abc1470
1301470abcabcabcabcabcabc1470abc1470
1311470abcabcabcabcabcabc1470abc1470
1321470abcabcabcabcabcabc1470abc1470
1331470abcabcabcabcabcabc1470abc1470
1341470abcabcabcabcabcabc1470abc1470
1351470abcabcabcabcabcabc1470abc1470
1361470abcabcabcabcabcabc1470abc1470
1371470abcabcabcabcabcabc1470abc1470
1381470abcabcabcabcabcabc1470abc1470
1391470abcabcabcabcabcabc1470abc1470
1401470abcabcabcabcabcabc1470abc1470
1411470abcabcabcabcabcabc1470abc1470
1421470abcabcabcabcabcabc1470abc1470
1431470abcabcabcabcabcabc1470abc1470
1441470abcabcabcabcabcabc1470abc1470
1451470abcabcabcabcabcabc1470abc1470
1461470abcabcabcabcabcabc1470abc1470
1471470abcabcabcabcabcabc1470abc1470
1481470abcabcabcabcabcabc1470abc1470
1491470abcabcabcabcabcabc1470abc1470
1501470abcabcabcabcabcabc1470abc1470
1511470abcabcabcabcabcabc1470abc1470
1521470abcabcabcabcabcabc1470abc1470
1531470abcabcabcabcabcabc1470abc1470
1541470abcabcabcabcabcabc1470abc1470
1551470abcabcabcabcabcabc1470abc1470
1561470abcabcabcabcabcabc1470abc1470
1571470abcabcabcabcabcabc1470abc1470
1581470abcabcabcabcabcabc1470abc1470
1591470abcabcabcabcabcabc1470abc1470
1601470abcabcabcabcabcabc1470abc1470
1611470abcabcabcabcabcabc1470abc1470
1621470abcabcabcabcabcabc1470abc1470
163
164
165
166
167
168
169
170
171
172
173
174
175a
176a
177
178
179XXXXXXXXXPB
180XXXXXXXXX
181XXXXXXXXX
182XXXXXXXXX
183XXXXXXXXX
184XXXXXXXXX
185XXXXXXXXX
186XXXXXXXXX
187XXXXXXXXX
188XXXXXXXXX
189XXXXXXXXX
190XXXXXXXXX
191XXXXXXXXX
192XXXXXXXXX
193XXXXXXXXX
194XXXXXXXXX
195XXXXXXXXX
196XXXXXXXXX
197XXXXXXXXX
KKK


For this example, I have worked out some code. It was working just as needed but after I changed the file location, now its not saving the pdf files as intended.

Can somebody please take a look and help me find what I am doing wrong!


VBA Code:
Sub Page_Formatting()
Dim i As Range, C As Range, K As Range, J As Range
Dim active_sheet As Variant, page_nums As Variant
Dim sCurrentPrinter As String, sPDFwriter As String
Dim strPath As String

MyPrinter = FindPrinter("Microsoft Print to PDF")

sPDFwriter = MyPrinter

    sCurrentPrinter = Application.ActivePrinter
    Application.ActivePrinter = sPDFwriter

    With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C
    End With

Set active_sheet = ThisWorkbook.ActiveSheet
page_nums = active_sheet.PageSetup.Pages.Count

    On Error Resume Next
    Application.PrintCommunication = True
    Err.Clear

    With ActiveSheet.PageSetup
    .PrintTitleRows = "$4:$4"
    ActiveSheet.PrintOut From:=1, To:=page_nums - 1, PrintToFile:=True, PrToFileName:=".pdf"
    .PrintTitleRows = ""
    ActiveSheet.PrintOut From:=page_nums, To:=page_nums, PrintToFile:=True, PrToFileName:="B.pdf"
    End With

End Sub

Function FindPrinter(ByVal PrinterName As String) As String


  Dim Arr As Variant
  Dim Device As Variant
  Dim Devices As Variant
  Dim Printer As String
  Dim RegObj As Object
  Dim RegValue As String
  Const HKEY_CURRENT_USER = &H80000001
     
    Set RegObj = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    RegObj.enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Devices, Arr
   
      For Each Device In Devices
        RegObj.getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Device, RegValue
        Printer = Device & " on " & Split(RegValue, ",")(1)
        If InStr(1, Printer, PrinterName, vbTextCompare) > 0 Then
           FindPrinter = Printer
           Exit Function
        End If
      Next
     
End Function
 
Upvote 0
This code is not perfect or optimized as it should be! So if you have suggestion to optimize it, please do share.

VBA Code:
With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

This can be optimized to select the top cell and select till the last non blank cell of the column. I have tried different methods I found but can't seem to get it to work.

VBA Code:
Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C

This portion can also be optimized by rather checking every cell of the range, should be select the only cell with value in it!

@Peter_SSs , @Fluff Please have a look!
 
Upvote 0
@Akuini I have finally worked out the code for solution!
Please take a look and see if you have help optimize it.
Especially the points I have highlighted earlier. The reason for that is, as I have mentioned, I will configure the code to work on multiple sheets with variable number of rows. currently this part takes time since it cycles through all cells of the range. That is why this should be optimized!

VBA Code:
Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C

The second point of optimization is covered with fixed range but still can be simplified, I think!

VBA Code:
With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Here is the example I had for the code!

Example TS - Copy.xlsm
ABCDEFGHIJKL
11
22Date :1-Oct
33
4ABCDEFGHIRow Labels
510abcabcabcabcabcabc10abc10
620abcabcabcabcabcabc20abc20
730abcabcabcabcabcabc30abc30
840abcabcabcabcabcabc40abc40
950abcabcabcabcabcabc50abc50
1060abcabcabcabcabcabc60abc60
1170abcabcabcabcabcabc70abc70
121170abcabcabcabcabcabc1170abc1170
131180abcabcabcabcabcabc1180abc1180
141190abcabcabcabcabcabc1190abc1190
151200abcabcabcabcabcabc1200abc1200
161210abcabcabcabcabcabc1210abc1210
171220abcabcabcabcabcabc1220abc1220
181230abcabcabcabcabcabc1230abc1230
191240abcabcabcabcabcabc1240abc1240
201250abcabcabcabcabcabc1250abc1250
211260abcabcabcabcabcabc1260abc1260
221270abcabcabcabcabcabc1270abc1270
231280abcabcabcabcabcabc1280abc1280
241290abcabcabcabcabcabc1290abc1290
251300abcabcabcabcabcabc1300abc1300
261310abcabcabcabcabcabc1310abc1310
271320abcabcabcabcabcabc1320abc1320
281330abcabcabcabcabcabc1330abc1330
291340abcabcabcabcabcabc1340abc1340
301350abcabcabcabcabcabc1350abc1350
311360abcabcabcabcabcabc1360abc1360
321370abcabcabcabcabcabc1370abc1370
331380abcabcabcabcabcabc1380abc1380
341390abcabcabcabcabcabc1390abc1390
351400abcabcabcabcabcabc1400abc1400
361410abcabcabcabcabcabc1410abc1410
371420abcabcabcabcabcabc1420abc1420
381430abcabcabcabcabcabc1430abc1430
391440abcabcabcabcabcabc1440abc1440
401450abcabcabcabcabcabc1450abc1450
411460abcabcabcabcabcabc1460abc1460
421470abcabcabcabcabcabc1470abc1470
431470abcabcabcabcabcabc1470abc1470
441470abcabcabcabcabcabc1470abc1470
451470abcabcabcabcabcabc1470abc1470
461470abcabcabcabcabcabc1470abc1470
471470abcabcabcabcabcabc1470abc1470
481470abcabcabcabcabcabc1470abc1470
491470abcabcabcabcabcabc1470abc1470
501470abcabcabcabcabcabc1470abc1470
511470abcabcabcabcabcabc1470abc1470
521470abcabcabcabcabcabc1470abc1470
531470abcabcabcabcabcabc1470abc1470
541470abcabcabcabcabcabc1470abc1470
551470abcabcabcabcabcabc1470abc1470
561470abcabcabcabcabcabc1470abc1470
571470abcabcabcabcabcabc1470abc1470
581470abcabcabcabcabcabc1470abc1470
591470abcabcabcabcabcabc1470abc1470
601470abcabcabcabcabcabc1470abc1470
611470abcabcabcabcabcabc1470abc1470
621470abcabcabcabcabcabc1470abc1470
631470abcabcabcabcabcabc1470abc1470
641470abcabcabcabcabcabc1470abc1470
651470abcabcabcabcabcabc1470abc1470
661470abcabcabcabcabcabc1470abc1470
671470abcabcabcabcabcabc1470abc1470
681470abcabcabcabcabcabc1470abc1470
691470abcabcabcabcabcabc1470abc1470
701470abcabcabcabcabcabc1470abc1470
711470abcabcabcabcabcabc1470abc1470
721470abcabcabcabcabcabc1470abc1470
731470abcabcabcabcabcabc1470abc1470
741470abcabcabcabcabcabc1470abc1470
751470abcabcabcabcabcabc1470abc1470
761470abcabcabcabcabcabc1470abc1470
771470abcabcabcabcabcabc1470abc1470
781470abcabcabcabcabcabc1470abc1470
791470abcabcabcabcabcabc1470abc1470
801470abcabcabcabcabcabc1470abc1470
811470abcabcabcabcabcabc1470abc1470
821470abcabcabcabcabcabc1470abc1470
831470abcabcabcabcabcabc1470abc1470
841470abcabcabcabcabcabc1470abc1470
851470abcabcabcabcabcabc1470abc1470
861470abcabcabcabcabcabc1470abc1470
871470abcabcabcabcabcabc1470abc1470
881470abcabcabcabcabcabc1470abc1470
891470abcabcabcabcabcabc1470abc1470
901470abcabcabcabcabcabc1470abc1470
911470abcabcabcabcabcabc1470abc1470
921470abcabcabcabcabcabc1470abc1470
931470abcabcabcabcabcabc1470abc1470
941470abcabcabcabcabcabc1470abc1470
951470abcabcabcabcabcabc1470abc1470
961470abcabcabcabcabcabc1470abc1470
971470abcabcabcabcabcabc1470abc1470
981470abcabcabcabcabcabc1470abc1470
991470abcabcabcabcabcabc1470abc1470
1001470abcabcabcabcabcabc1470abc1470
1011470abcabcabcabcabcabc1470abc1470
1021470abcabcabcabcabcabc1470abc1470
1031470abcabcabcabcabcabc1470abc1470
1041470abcabcabcabcabcabc1470abc1470
1051470abcabcabcabcabcabc1470abc1470
1061470abcabcabcabcabcabc1470abc1470
1071470abcabcabcabcabcabc1470abc1470
1081470abcabcabcabcabcabc1470abc1470
1091470abcabcabcabcabcabc1470abc1470
1101470abcabcabcabcabcabc1470abc1470
1111470abcabcabcabcabcabc1470abc1470
1121470abcabcabcabcabcabc1470abc1470
1131470abcabcabcabcabcabc1470abc1470
1141470abcabcabcabcabcabc1470abc1470
1151470abcabcabcabcabcabc1470abc1470
1161470abcabcabcabcabcabc1470abc1470
1171470abcabcabcabcabcabc1470abc1470
1181470abcabcabcabcabcabc1470abc1470
1191470abcabcabcabcabcabc1470abc1470
1201470abcabcabcabcabcabc1470abc1470
1211470abcabcabcabcabcabc1470abc1470
1221470abcabcabcabcabcabc1470abc1470
1231470abcabcabcabcabcabc1470abc1470
1241470abcabcabcabcabcabc1470abc1470
1251470abcabcabcabcabcabc1470abc1470
1261470abcabcabcabcabcabc1470abc1470
1271470abcabcabcabcabcabc1470abc1470
1281470abcabcabcabcabcabc1470abc1470
1291470abcabcabcabcabcabc1470abc1470
1301470abcabcabcabcabcabc1470abc1470
1311470abcabcabcabcabcabc1470abc1470
1321470abcabcabcabcabcabc1470abc1470
1331470abcabcabcabcabcabc1470abc1470
1341470abcabcabcabcabcabc1470abc1470
1351470abcabcabcabcabcabc1470abc1470
1361470abcabcabcabcabcabc1470abc1470
1371470abcabcabcabcabcabc1470abc1470
1381470abcabcabcabcabcabc1470abc1470
1391470abcabcabcabcabcabc1470abc1470
1401470abcabcabcabcabcabc1470abc1470
1411470abcabcabcabcabcabc1470abc1470
1421470abcabcabcabcabcabc1470abc1470
1431470abcabcabcabcabcabc1470abc1470
1441470abcabcabcabcabcabc1470abc1470
1451470abcabcabcabcabcabc1470abc1470
1461470abcabcabcabcabcabc1470abc1470
1471470abcabcabcabcabcabc1470abc1470
1481470abcabcabcabcabcabc1470abc1470
1491470abcabcabcabcabcabc1470abc1470
1501470abcabcabcabcabcabc1470abc1470
1511470abcabcabcabcabcabc1470abc1470
1521470abcabcabcabcabcabc1470abc1470
1531470abcabcabcabcabcabc1470abc1470
1541470abcabcabcabcabcabc1470abc1470
1551470abcabcabcabcabcabc1470abc1470
1561470abcabcabcabcabcabc1470abc1470
1571470abcabcabcabcabcabc1470abc1470
1581470abcabcabcabcabcabc1470abc1470
1591470abcabcabcabcabcabc1470abc1470
1601470abcabcabcabcabcabc1470abc1470
1611470abcabcabcabcabcabc1470abc1470
1621470abcabcabcabcabcabc1470abc1470
163
164
165
166
167
168
169
170
171
172
173
174
175a
176a
177
178
179XXXXXXXXXPB
180XXXXXXXXX
181XXXXXXXXX
182XXXXXXXXX
183XXXXXXXXX
184XXXXXXXXX
185XXXXXXXXX
186XXXXXXXXX
187XXXXXXXXX
188XXXXXXXXX
189XXXXXXXXX
190XXXXXXXXX
191XXXXXXXXX
192XXXXXXXXX
193XXXXXXXXX
194XXXXXXXXX
195XXXXXXXXX
196XXXXXXXXX
197XXXXXXXXX
KKK



If you run the Page_Formatting Macro, It will produce 3 PDF files. Part 1 and 2 are just to ensure repeat row header is not repeated on last page and then call another macro to merg the PDF files in the folder location.

VBA Code:
Sub Page_Formatting()
Dim i As Range, C As Range, K As Range, J As Range
Dim active_sheet As Variant, page_nums As Variant
Dim sCurrentPrinter As String, sPDFwriter As String
Dim File1 As String, File2 As String

File1 = ActiveWorkbook.Path & "\Part - 1.pdf"
File2 = ActiveWorkbook.Path & "\Part - 2.pdf"


MyPrinter = FindPrinter("Microsoft Print to PDF")

sPDFwriter = MyPrinter

    sCurrentPrinter = Application.ActivePrinter
    Application.ActivePrinter = sPDFwriter

    With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C
    End With

Set active_sheet = ThisWorkbook.ActiveSheet
page_nums = active_sheet.PageSetup.Pages.Count

    On Error Resume Next
    Application.PrintCommunication = True
    Err.Clear

    With ActiveSheet.PageSetup
    .PrintTitleRows = "$4:$4"
    ActiveSheet.PrintOut From:=1, To:=page_nums - 1, PrintToFile:=True, PrToFileName:=File1
    .PrintTitleRows = ""
    ActiveSheet.PrintOut From:=page_nums, To:=page_nums, PrintToFile:=True, PrToFileName:=File2
    End With
Call MergePDF
End Sub

Function FindPrinter(ByVal PrinterName As String) As String

  Dim Arr As Variant
  Dim Device As Variant
  Dim Devices As Variant
  Dim Printer As String
  Dim RegObj As Object
  Dim RegValue As String
  Const HKEY_CURRENT_USER = &H80000001
      
    Set RegObj = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    RegObj.enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Devices, Arr
    
      For Each Device In Devices
        RegObj.getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Device, RegValue
        Printer = Device & " on " & Split(RegValue, ",")(1)
        If InStr(1, Printer, PrinterName, vbTextCompare) > 0 Then
           FindPrinter = Printer
           Exit Function
        End If
      Next
End Function

Sub MergePDF()

Dim n As Long, PDFfileName As String
'Relies on the Adobe Acrobat 6.0 Type Library
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc

'Initialize the objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")

'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (ThisWorkbook.Path & "\Part - 1.pdf")
n = 1
    Do
        n = n + 1
        PDFfileName = Dir(ThisWorkbook.Path & "\Part - " & n & ".pdf")
        If PDFfileName <> "" Then
            'Open the source document that will be added to the destination
            objCAcroPDDocSource.Open ThisWorkbook.Path & "\" & PDFfileName
            If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
                MsgBox "Merged " & PDFfileName
            Else
                MsgBox "Error merging " & PDFfileName
            End If
            objCAcroPDDocSource.Close
        End If
    Loop While PDFfileName <> ""

objCAcroPDDocDestination.Save 1, ThisWorkbook.Path & "\Report (Complete).pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing

End Sub


@Akuini I would really appreciate if you could help optimize this code.
 
Upvote 0
This part will make the code loop on every cell in the whole column J.
VBA Code:
            Set i = Range("J:J")
            For Each C In i

Change this part:
VBA Code:
    With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C
    End With
to this:

VBA Code:
    Range("L4:L176").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    Dim sAddress As String
    With Range("J:J")
        Set c = .Find(What:="PB", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                sAddress = c.Address
                Do
                   c.EntireRow.PageBreak = xlPageBreakManual
                   Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> sAddress
            End If
    End With

Note: I didn't test the code, I just thought that your code could be revised like this to make it work more efficiently.
 
Upvote 0
Solution
This part will make the code loop on every cell in the whole column J.
VBA Code:
            Set i = Range("J:J")
            For Each C In i

Change this part:
VBA Code:
    With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C
    End With
to this:

VBA Code:
    Range("L4:L176").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    Dim sAddress As String
    With Range("J:J")
        Set c = .Find(What:="PB", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                sAddress = c.Address
                Do
                   c.EntireRow.PageBreak = xlPageBreakManual
                   Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> sAddress
            End If
    End With

Note: I didn't test the code, I just thought that your code could be revised like this to make it work more efficiently.
Thanks for your insight, it will definitely test it out tomorrow and share the results. Current I have converted my code to work on 9 worksheets with variable heights (no of rows) ranging from 100 to 5000 rows each. And it takes about 110 sec to process through all of them.

This loop will definitely help reduce the time trying to find 1 value in whole colum.

Again thanks for your valuable input.
 
Upvote 0
This part will make the code loop on every cell in the whole column J.
VBA Code:
            Set i = Range("J:J")
            For Each C In i

Change this part:
VBA Code:
    With Range("L4:L176").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Set i = Range("J:J")
            For Each C In i
            If C = "PB" Then
                ActiveSheet.Rows(C.Row).PageBreak = xlPageBreakManual
            End If
        Next C
    End With
to this:

VBA Code:
    Range("L4:L176").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    Dim sAddress As String
    With Range("J:J")
        Set c = .Find(What:="PB", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                sAddress = c.Address
                Do
                   c.EntireRow.PageBreak = xlPageBreakManual
                   Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> sAddress
            End If
    End With

Note: I didn't test the code, I just thought that your code could be revised like this to make it work more efficiently.
@Akuini Tried your snippet and its great, reduces the overall time by 18 secs!

Again Thanks a lot for your time!
 
Upvote 0

Forum statistics

Threads
1,214,588
Messages
6,120,412
Members
448,960
Latest member
AKSMITH

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top