Loop through drop down list and save range as PDF

[Jasesair]

I have a drop down list (Data Validation List) in cell A3 of a sheet called "End of Season". When I select from the drop down list, the data in the sheet changes appropriately. I'd like some code that loops through every drop down and saves each time as a PDF. Ideally, this would save as one PDF but I can handle if each loop saves a separate PDF. The range to be saved is A1:X39 each time.

Any help to do this would be very much appreciated - it'd be a real time saver.

 

[John_w]

Many thanks - the macro is back working again. When this is copying to the temporary sheet, it must not be bringing the row widths with it, which means it won't look as it should. Is there a possible fix for this? I'm new to VBA so have been Googling but can't work this out myself unfortunately. My aim is for the copying to be the same as the original sheet with column widths, row heights, margins etc.

Do you mean row heights? You can see the temporary sheet by commenting out the .Delete line.

Row heights can be preserved with the Format Painter on entire rows.

Public Sub Create_PDF2()

    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
   
    With ActiveWorkbook
   
        'PDF file name
       
        PDFfullName = .Path & "\End of Season.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("End of Season").Range("A3")
       
        'Range to be copied to temporary sheet for each dropdown value
       
        Set copyRange = .Worksheets("End of Season").Range("A1:X39")
       
    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
   
        '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 = xlPortrait 'xlLandscape
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfullName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
   
End Sub

A different approach, rather than copying and pasting formats, column widths, row heights, etc., would be to copy the range and paste it as a Picture on the temporary sheet.

 

[Jasesair]

Really appreciate your time, John_w. It's so close now. I've added in margins information but the picture hasn't reduced quite enough to fit on the page. It doesn't miss by much. To confirm, when I print preview, it fits perfectly and with no scaling. Any ideas?

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
   
    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
   
        '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

 

[John_w]

One way is to reduce the size of the picture, say to 95% of the original.

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

 

[Jasesair]

Hi John, it's been a while, I know, but wonder if you can help with a tiny correction with this code. The first saved page is saving slightly bigger than every other page. It's like the 95% adjustment is working on every other page, except the first page. Could that be correct? End result is the first page is carrying over to two pages, then every subsequent page is perfect.

 

[John_w]

I don't see how the first page would be different to the other pages. Does the first page fit with a smaller scale factor? If so, store the scale factor in a variable, set it to 90%, say, outside the loop, and 95% before the end of the loop.