Sub MrE1221718_1613D0B()
'https://www.mrexcel.com/board/threads/print-excel-to-pdf-for-rows-of-unique-values.1221718/
'last updated: 13. Nov. 2022, HaHoBe
'
'Requirements:
' - sheet with data in listform ("New POs"), headers in row 1, data starts in row 2
' - sheet for taking the 3 rows of filtered data for PDF ("Contract Form")
'
' - sheet for taking the 3 rows of filtered data and copying the next rows on second page
' second page will look different from first page taking only some data from first page
' using formulas for the first 4 rows as well as the number of page
' starting at row 6 (fix) as header and relativ from row 11 + data exceeding 3
' the maximum of rows per data to copy for sheet 2 will be set by a constant to allow a total of
' 12 rows for one Pile as I setup here with clngMaxNumPile.
' Check for total number of rows will be taken after setting the range to work,
' if number of rows is larger than the constant for max rows a comment will be set at the far right end
' to flag those Piles which have not been processed and a counter will be augmented for
' information on how many Piles were marked ("Contract Form+")
' you should adjust this sheet to meet your criteria for printout to PDF
' - "Contract Form+" at present is limited for taking two pages as printout
'Defining Variables
Dim dblEnd As Double
Dim dblStart As Double
Dim lngCounter As Long 'looping the dictionary
Dim lngLoop As Long 'taking the row number of the filtered data to work on
Dim lngOffset As Long 'needed for getting the next row in Printout for data
Dim lngRowsBetween As Long 'needed to keep distance between the blocks of data
Dim lngSecLoop As Long 'used for the second page as Counter
Dim lngSkip As Long 'taking the number of Piles that were not processed
Dim lngWork As Long 'number of rows in the AutoFilter data range
Dim rngWork As Range 'data range for each single PO
Dim rngArea As Range 'might be needed if range is not continuous
Dim rngCell As Range 'need for looping through each area
Dim objScDir As Object 'late binding for scripting.dictionary
Dim strInfo As String 'text to hold item not processed and number of rows
Dim strPath As String 'reading in the path to the user and given folder
Dim strReturn As String 'for checkiong availabilty of path
Dim strStamp As String 'taking date/time stamp to add to PO for saving
Dim wsDetails As Worksheet 'worksheet with the raw data
Dim wsReport As Worksheet 'sheet for taking data for output
'Constants for the sheets we will work with
Const cstrDETAILS As String = "New POs"
Const cstrREPORIG As String = "Contract Form"
Const cstrREPALT As String = "Contract Form+"
'Constants for Ranges and Values used later on
Const clngColFilter As Long = 2
Const clngStartCom As Long = 34 'start row for second page as header row
Const clngMaxNumPile As Long = 12 'limiting the number of items per Pile
Const cstrSKIP As String = "not processed" 'text to notify
Const cstrCliAddFro As String = "O"
Const cstrCliAddTo As String = "F"
Const cstrClientFro As String = "A"
Const cstrClientTo As String = "F"
Const cstrCliTwnZipFr As String = "P"
Const cstrCliTwnZipTo As String = "F"
Const cstrCommodFro As String = "B"
Const cstrCommodTo As String = "A"
Const cstrDelCityFro As String = "I"
Const cstrDelCityTo As String = "B"
Const cstrIncotermFro As String = "H"
Const cstrIncotermTo As String = "D"
Const cstrOptionFro As String = "C"
Const cstrOptionTo As String = "E"
Const cstrPOFrom As String = "K"
Const cstrPOTo As String = "F"
Const cstrPriceMTFro As String = "E"
Const cstrPriceMTTo As String = "B"
Const cstrQtyMTFro As String = "D"
Const cstrQtyMTTo As String = "A"
On Error GoTo err_here
dblStart = Timer
'Check all sheets are present in ActiveWorkbook
If Not Evaluate("ISREF('" & cstrDETAILS & "'!A1)") Then
MsgBox "Cannot find sheet '" & cstrDETAILS & "', please check.", vbInformation, "No match for " & cstrDETAILS
GoTo end_here
End If
If Sheets(cstrDETAILS).UsedRange.Address = Range("A1").Address Then
MsgBox "Cannot find data on sheet '" & cstrDETAILS & "', please check.", vbInformation, "No data found in " & cstrDETAILS
GoTo end_here
End If
If Not Evaluate("ISREF('" & cstrREPORIG & "'!A1)") Then
MsgBox "Cannot find sheet '" & cstrREPORIG & "', please check.", vbInformation, "No match for " & cstrREPORIG
GoTo end_here
End If
If Not Evaluate("ISREF('" & cstrREPALT & "'!A1)") Then
MsgBox "Cannot find sheet '" & cstrREPALT & "', please check.", vbInformation, "No match for " & cstrREPALT
GoTo end_here
End If
'check we have a valid path to save
strPath = Environ("Userprofile") & "\Desktop\"
strReturn = Dir(Left(strPath, Len(strPath) - 1), vbDirectory)
If strReturn = "" Then
MsgBox "Error in Path to '" & strPath, vbInformation, "Folder cannot be found"
GoTo end_here
End If
Application.ScreenUpdating = False
'starting work here
Set wsDetails = ActiveWorkbook.Sheets(cstrDETAILS)
Set objScDir = CreateObject("scripting.dictionary")
'set any Autofilter off, build a range towork on for unique POs
With wsDetails
.AutoFilterMode = False
'if any remarks about skipped items clear column
If WorksheetFunction.CountIf(.Columns(.Cells(1, .Columns.Count).End(xlToLeft).Column + 1), cstrSKIP) > 0 Then
.Columns(.Cells(1, .Columns.Count).End(xlToLeft).Column + 1).ClearContents
End If
Set rngWork = .Range(.Cells(2, clngColFilter), .Cells(Rows.Count, clngColFilter).End(xlUp))
End With
'loop through the range and add value to dictionary, item will only be accdepted if not present
For Each rngCell In rngWork
objScDir(rngCell.Value) = Empty
Next rngCell
With wsDetails
'loop through the dictionary
For lngCounter = 0 To objScDir.Count - 1
'set autoFilter on Column with Key
.Range("A1").CurrentRegion.AutoFilter field:=clngColFilter, Criteria1:=objScDir.Keys()(lngCounter)
Set rngWork = .Range(.Cells(2, clngColFilter), .Cells(Rows.Count, clngColFilter).End(xlUp)).SpecialCells(xlCellTypeVisible)
'check for continuing or flagging data to show too many items
lngWork = rngWork.Cells.Count
If lngWork > clngMaxNumPile Then
rngWork.Offset(, wsDetails.Cells(1, wsDetails.Columns.Count).End(xlToLeft).Column - 1).Value = cstrSKIP
strInfo = strInfo & vbCrLf & objScDir.Keys()(lngCounter) & ": " & vbTab & lngWork & " rows"
lngSkip = lngSkip + 1
GoTo continue_here
End If
lngRowsBetween = lngWork - 1
lngSecLoop = 0
lngOffset = -1
'decide which report should be used
If rngWork.Cells.Count <= 3 Then
Set wsReport = ActiveWorkbook.Sheets(cstrREPORIG)
Else
Set wsReport = ActiveWorkbook.Sheets(cstrREPALT)
End If
For Each rngArea In rngWork
For Each rngCell In rngArea
lngOffset = lngOffset + 1
lngLoop = rngCell.Row
If lngOffset = 0 Then
' SOption
wsReport.Cells(17, cstrOptionTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrOptionFro)
' SIncoterm
wsReport.Cells(17, cstrIncotermTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrIncotermFro)
' SClient
wsReport.Cells(10, cstrClientTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrClientFro)
' SClientAddress
wsReport.Cells(11, cstrCliAddTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrCliAddFro)
' SClientTownZip
wsReport.Cells(12, cstrCliTwnZipTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrCliTwnZipFr)
' SPO
wsReport.Cells(17, cstrPOTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrPOFrom)
End If
If lngOffset < 3 Then
' SCommodity
wsReport.Cells(17, cstrCommodTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrCommodFro)
' SQtyMT
wsReport.Cells(21, cstrQtyMTTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrQtyMTFro)
' SDeliveryCity
wsReport.Cells(17, cstrDelCityTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrDelCityFro)
' SPriceMT
wsReport.Cells(21, cstrPriceMTTo).Offset(lngOffset).Value = wsDetails.Cells(lngLoop, cstrPriceMTFro)
Else
' 'working on the second page for the printout
lngSecLoop = lngSecLoop + 1
'Inserting the headers, Commodity and DeliverCity may remain but the other 2 are vaiable
If lngSecLoop = 1 Then
wsReport.Cells(clngStartCom, cstrCommodTo).Value = "Commodity"
wsReport.Cells(clngStartCom + lngRowsBetween, cstrQtyMTTo).Value = "QtyMT"
wsReport.Cells(clngStartCom, cstrDelCityTo).Value = "DeliveryCity"
wsReport.Cells(clngStartCom + lngRowsBetween, cstrPriceMTTo).Value = "PriceMT"
End If
' SCommodity
wsReport.Cells(clngStartCom, cstrCommodTo).Offset(lngSecLoop).Value = wsDetails.Cells(lngLoop, cstrCommodFro)
' SQtyMT
wsReport.Cells(clngStartCom + lngRowsBetween, cstrQtyMTTo).Offset(lngSecLoop).Value = wsDetails.Cells(lngLoop, cstrQtyMTFro)
' SDeliveryCity
wsReport.Cells(clngStartCom, cstrDelCityTo).Offset(lngSecLoop).Value = wsDetails.Cells(lngLoop, cstrDelCityFro)
' SPriceMT
wsReport.Cells(clngStartCom + lngRowsBetween, cstrPriceMTTo).Offset(lngSecLoop).Value = wsDetails.Cells(lngLoop, cstrPriceMTFro)
End If
Next rngCell
Next rngArea
strStamp = Format(Now(), "_yymmdd_hhmmss")
'Save the PDF file
If wsReport.Name = cstrREPORIG Then
With wsReport.PageSetup
.Zoom = False
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
wsReport.Range("A1:G28").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPath & wsReport.Cells(17, 6).Value & strStamp & ".PDF", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
wsReport.Cells(17, cstrCommodTo).Resize(4, 1).ClearContents
wsReport.Cells(21, cstrQtyMTTo).Resize(4, 1).ClearContents
wsReport.Cells(17, cstrDelCityTo).Resize(4, 1).ClearContents
wsReport.Cells(21, cstrPriceMTTo).Resize(4, 1).ClearContents
Else
'/// You would need to adapt your worksheet setup to match by recording a macro and paste the code in here.
'/// Please mind that I use wsReport while the macro recorder should use ActiveSheet
'/// or ActiveWindow.SelectedSheets
' With wsReport.PageSetup
' .Zoom = False
' .Orientation = xlPortrait
' .FitToPagesWide = 1
' .FitToPagesTall = 1
' End With
wsReport.HPageBreaks.Add Before:=Range("A29")
wsReport.Range("A1:G56").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPath & wsReport.Cells(17, 6).Value & strStamp & ".PDF", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
wsReport.Cells(17, cstrCommodTo).Resize(3, 1).ClearContents
wsReport.Cells(21, cstrQtyMTTo).Resize(3, 1).ClearContents
wsReport.Cells(17, cstrDelCityTo).Resize(3, 1).ClearContents
wsReport.Cells(21, cstrPriceMTTo).Resize(3, 1).ClearContents
'deleting the range on the second page starting at row 6 and cstrCommodTo ("A") up to the last entry in cstrDelCityTo ("B")
'this includes deleting the headers
wsReport.Range(wsReport.Cells(clngStartCom, cstrCommodTo), wsReport.Cells(wsReport.Rows.Count, cstrDelCityTo).End(xlUp)).ClearContents
End If
continue_here:
Next lngCounter
End With
end_here:
wsDetails.AutoFilterMode = False
dblEnd = Timer
Debug.Print "Finished! Duration: " & dblEnd - dblStart & " seconds"
Debug.Print "Number of items: " & objScDir.Count
Debug.Print "Number of Piles skipped: " & lngSkip
Debug.Print "Total number of rows: " & wsDetails.Cells(wsDetails.Rows.Count, clngColFilter).End(xlUp).Row - 1
If lngSkip > 0 Then
MsgBox lngSkip & " Pile(s) showed a number of more than " & clngMaxNumPile & "." & vbCrLf & _
IIf(lngSkip > 2, "Please consider to setup another page or more pages for printout.", "") & _
vbCrLf & vbCrLf & "Information on items and max number:" & strInfo, _
vbInformation, "Some PILES were not processed"
End If
Set wsReport = Nothing
Set rngWork = Nothing
Set wsDetails = Nothing
Set objScDir = Nothing
Application.ScreenUpdating = True
Exit Sub
err_here:
MsgBox "An error occurred, more information in the Immediate Window", , "Sorry..."
Debug.Print "Error Number: " & Err.Number
Debug.Print "Error Description: " & Err.Description
Resume end_here
End Sub
