Public Sub Create_PDF()
Dim PDFfullName As String
Dim PDFsheet As Worksheet
Dim destCell As Range
Dim dataValidationCell As Range, dataValidationListSource As Range, dvValueCell As Range
Dim copyRange As Range
Dim pic As Picture
With ActiveWorkbook
'PDF file name
PDFfullName = .Path & "\Season Summary.pdf"
'Add temporary sheet for PDF output
Set PDFsheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
Set destCell = PDFsheet.Range("A1")
'Cell containing data validation in-cell dropdown
Set dataValidationCell = .Worksheets("Season Summary").Range("D3")
'Range to be copied to temporary sheet for each dropdown value
Set copyRange = .Worksheets("Season Summary").Range("A1:V39")
End With
'Source of data validation list
Set dataValidationListSource = Evaluate(dataValidationCell.Validation.Formula1)
'Loop through each data validation value to update range
For Each dvValueCell In dataValidationListSource
dataValidationCell.Value = dvValueCell.Value
'Copy cell formats, column widths, the picture and cell values to next cell in temporary PDF sheet
copyRange.Copy
destCell.Select
destCell.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
destCell.Worksheet.Paste
destCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Use Format Painter to apply row heights
copyRange.EntireRow.Copy
With PDFsheet
.Range(destCell, .Cells(.UsedRange.Rows.Count, 1)).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Get last picture on PDF sheet and reduce its size to 95% of original
Set pic = PDFsheet.Pictures(PDFsheet.Pictures.Count)
pic.ShapeRange.ScaleHeight 0.95, msoFalse, msoScaleFromTopLeft
'Update destination cell to next row
With PDFsheet
.HPageBreaks.Add Before:=.Rows(.UsedRange.Rows.Count + 1)
Set destCell = .Cells(.UsedRange.Rows.Count + 1, 1)
End With
Next
'Save temporary sheet as PDF then delete it
With PDFsheet
.PageSetup.Orientation = xlLandscape 'xlPortrait
.PageSetup.LeftMargin = Application.CentimetersToPoints(0.9)
.PageSetup.RightMargin = Application.CentimetersToPoints(0.9)
.PageSetup.TopMargin = Application.CentimetersToPoints(0.9)
.PageSetup.BottomMargin = Application.CentimetersToPoints(0.9)
.PageSetup.HeaderMargin = Application.CentimetersToPoints(0)
.PageSetup.FooterMargin = Application.CentimetersToPoints(0)
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfullName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub