change Excel VBA: prompt user for folder save location

[willgarling]

I have a macro that cycles through all values in a pivot filter and saves individual PDFs for each filtered value. The problem is the macro will save the PDFs in the current excel file location. How do I adjust the macro to prompt the user for the folder location to save the PDFs? The prompt only needs to happen 1 time and then every PDF would be saved in the location selected by the user. Thanks for the help!!

Sub PrintPivotPages()
'prints a copy of pivot table for each item in page field
'assumes one page field exists
Application.ScreenUpdating = False


DirectoryLocation = ActiveWorkbook.Path


On Error Resume Next
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Set pt = ActiveSheet.PivotTables.Item(1)
For Each pf In pt.PageFields
For Each pi In pf.PivotItems
        pt.PivotFields(pf.Name).CurrentPage = pi.Name
        


        Name = DirectoryLocation & "\" & Range("B8").Value & ".pdf"
        
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Name _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
        
Next
Next pf


Application.ScreenUpdating = True


End Sub

 

[ranman256]

the SaveMyFile will ask user for the path, then use your code to make the file...

Public Sub SaveMyFile()
Dim vFil
vFil = UserPickFile("PDF", "C:\temp\")
If vFil <> "" Then
   MsgBox vFil
   'export to vFile
End If
End Sub

Public Function UserPickFile(ByVal pvFilter, Optional pvPath)
Dim strTable As String
Dim strFilePath As String
Dim sDialog As String, sDecr  As String, sExt As String
Dim i As Integer
Dim vFName
With Application.FileDialog(msoFileDialogSaveAs)   'MUST ADD REFERENCE : Microsoft Office 11.0 Object Library
'msoFileDialogSaveAs
'msoFileDialogFilePicker
    .AllowMultiSelect = False
    .Title = "Save File as"
    .ButtonName = "Save"
    '.Filters.Clear
    '.Filters.Add "Paint", "*.bmp;*.png"
    '.Filters.Add "Acrobat", "*.pdf"
    '.Filters.Add "Excel", "*.xls*"
    For i = 1 To .Filters.Count
        vFName = .Filters(i).Description
        If vFName = pvFilter Then
            .FilterIndex = i
            Exit For
        End If
   Next
    
    .InitialFileName = pvPath
    .InitialView = msoFileDialogViewList    'msoFileDialogViewThumbnail
        If .Show = 0 Then
           'There is a problem
           Exit Function
        End If
    'Save the first file selected
    UserPickFile = Trim(.SelectedItems(1))
End With
End Function