循环验证列表并将 pdf 打印到由单元格定义的文件夹

Question

我使用了一个类似问题的答案来获得下面的 vba。此 vba 脚本在文件夹路径被硬编码时有效，但我希望打印的 pdf 文件的文件夹由单元格（“G7”）定义。

Sub Loop_Through_List()
    
    Sheets("Report Template").Select
    Range("B5").Select
    
    Dim ws                    As Worksheet
    Dim cell                  As Excel.Range
    Dim rgDV                  As Excel.Range
    Dim DV_Cell               As Excel.Range
    Dim folderPath            As String

    folderPath = GetFolder(Range("G7").Value)
    'folderPath = GetFolder()

    Set DV_Cell = Range("B5")

    Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2))
    For Each cell In rgDV.Cells
        DV_Cell.Value = cell.Value
        PDFActiveSheet folderPath
    Next
    
    Sheets("Notes").Select
    Range("A1").Select
End Sub

Sub PDFActiveSheet(Optional ByVal folderPath As String = "")
    Dim ws                    As Worksheet
    Dim myFile                As Variant
    Dim strFile               As String
    Dim sFolder               As String
    On Error GoTo errHandler

    Set ws = ActiveSheet

    'enter name and select folder for file
    ' start in current workbook folder
    strFile = ws.Range("B5").Value

    If folderPath = "" Then
        '--- if no folder path is specified, then default to
        '    the same path as the active workbook
        folderPath = ActiveWorkbook.Path
        If Len(folderPath) = 0 Then
            '--- to force Excel to have a path (instead of no
            '    path at all), use the current directory
            '    notation
            folderPath = "."
        End If
    End If
    myFile = folderPath & "\" & strFile

    ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=myFile, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False, _
            From:=1, _
            To:=2

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Function GetFolder() As String
    Dim dlg                   As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.InitialFileName = ThisWorkbook.Path & "\"
    dlg.Title = "Select folder to save PDFs"
    If dlg.Show = -1 Then
        GetFolder = dlg.SelectedItems(1)
    End If
End Function

Answer 1

如果文件夹名称已经在单元格 G7 中，则不需要 GetFolder 函数：

当前代码

folderPath = GetFolder(Range("G7").Value)

替换为：

folderPath = Range("G7").Value

Answer 2

在 Mike 的帮助下，我得以完成它。最后，我使用 ActiveWorkbook.Path & "" 来定义文件夹路径。我不知道是否有任何代码是多余的，但它可以满足我的需要。非常感谢。

Sub Loop_Through_List()
    
    Sheets("Report Template").Select
    Range("B5").Select
    
    Dim ws                    As Worksheet
    Dim cell                  As Excel.Range
    Dim rgDV                  As Excel.Range
    Dim DV_Cell               As Excel.Range
    Dim folderPath            As String
    Dim Path            As String

    folderPath = ActiveWorkbook.Path & "\"
    'folderPath = GetFolder()

    Set DV_Cell = Range("B5")

    Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2))
    For Each cell In rgDV.Cells
        DV_Cell.Value = cell.Value
        PDFActiveSheet folderPath
    Next
    
    Sheets("Notes").Select
    Range("A1").Select
End Sub

Sub PDFActiveSheet(Optional ByVal folderPath As String = "")
    Dim ws                    As Worksheet
    Dim myFile                As Variant
    Dim strFile               As String
    Dim sFolder               As String
    On Error GoTo errHandler

    Set ws = ActiveSheet

    'enter name and select folder for file
    ' start in current workbook folder
    strFile = ws.Range("B5").Value

    If folderPath = "" Then
        '--- if no folder path is specified, then default to
        '    the same path as the active workbook
        folderPath = ActiveWorkbook.Path
        If Len(folderPath) = 0 Then
            '--- to force Excel to have a path (instead of no
            '    path at all), use the current directory
            '    notation
            folderPath = "."
        End If
    End If
    myFile = folderPath & "\" & strFile
    ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=myFile, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False, _
            From:=1, _
            To:=2

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Function GetFolder() As String
    Dim dlg                   As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.InitialFileName = ThisWorkbook.Path & "\"
    dlg.Title = "Select folder to save PDFs"
    If dlg.Show = -1 Then
        GetFolder = dlg.SelectedItems(1)
    End If
End Function