循环查看验证列表并将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"quot；以定义文件夹路径。我不知道是否有多余的代码，但它能满足我的需要。非常感谢。

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