循环数据validation列表并打印到当前文件夹中的PDF

我能够获取代码来遍历我的validation列表，并将其打印到列表中的每个项目的PDF。 有没有办法让我打印到当前的文件夹，所以它不会问我每次我想使用哪个文件夹？ 我只是不确定如何调整代码，甚至是否可以完成。

Sub Loop_Through_List() Dim cell As Excel.Range Dim rgDV As Excel.Range Dim DV_Cell As Excel.Range Set DV_Cell = Range("B1") Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2)) For Each cell In rgDV.Cells DV_Cell.Value = cell.Value Call PDFActiveSheet Next End Sub Sub PDFActiveSheet() 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("B1").Value & " Period " & ws.Range("J1").Value sFolder = GetFolder() If sFolder = "" Then MsgBox "No folder selected. Code will terminate." Exit Sub End If myFile = sFolder & "\" & 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

只有一些小的变化，以获得你想要的。 将我的示例代码添加到您的post中以便向您展示是比较容易的。

 Option Explicit Sub Loop_Through_List() Dim cell As Excel.Range Dim rgDV As Excel.Range Dim DV_Cell As Excel.Range Dim folderPath As String folderPath = "c:\hardcodedPathOrCallGetFolderOnceHere" 'folderPath = GetFolder() Set DV_Cell = Range("B1") Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2)) For Each cell In rgDV.Cells DV_Cell.Value = cell.Value PDFActiveSheet folderPath Next 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("B1").Value & " Period " & ws.Range("J1").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