Question

我能够获取代码以遍历我的验证列表，并为列表中的每个项目打印为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

只有一些小改动才能得到你想要的东西。将示例代码添加到帖子中以便向您展示更容易。

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

循环数据验证列表并在当前文件夹中打印到PDF

1 个答案: