Loop through drop down list and save range as PDF

Jasesair

Active Member
Joined
Apr 8, 2015
Messages
263
Office Version
  1. 2016
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,002
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.

VBA Code:
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.
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Jasesair

Active Member
Joined
Apr 8, 2015
Messages
263
Office Version
  1. 2016
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?

VBA Code:
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,002
One way is to reduce the size of the picture, say to 95% of the original.
VBA Code:
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

Active Member
Joined
Apr 8, 2015
Messages
263
Office Version
  1. 2016
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,002
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.
 

Forum statistics

Threads
1,141,402
Messages
5,706,245
Members
421,433
Latest member
yash0468

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
Top