根据用户表单复选框将特定范围导出为 pdf

Question

我想将最后一个范围导出为 PDF。

我在带有复选框的用户表单中使用以下代码：

Private Sub CommandButton1_Click()
    
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xYesorNo, I, xNum As Integer
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range
    Dim xArrShetts As Variant
    Dim xPDFNameAddress As String
    Dim xStr As String
    'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
    xArrShetts = sheetsArr(Me)
    
    For I = 0 To UBound(xArrShetts)
        On Error Resume Next
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        If xSht.Name <> xArrShetts(I) Then
            MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
        Exit Sub
        End If
    Next
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDlg.Show = True Then
        xFolder = xFileDlg.SelectedItems(1)
    Else
        MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
        Exit Sub
    End If
    
    'Check if file already exist
    xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
    vbYesNo + vbQuestion, "File Exists")
    If xYesorNo <> vbYes Then Exit Sub
    
    For I = 0 To UBound(xArrShetts)
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        
        xStr = xFolder & "\" & xSht.Name & ".pdf"
        xNum = 1
        While Not (Dir(xStr, vbDirectory) = vbNullString)
            xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
            xNum = xNum + 1
        Wend
        Set xUsedRng = xSht.UsedRange
        If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
            xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
        End If
        xArrShetts(I) = xStr
    Next
    
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = "????"
        For I = 0 To UBound(xArrShetts)
            .Attachments.Add xArrShetts(I)
        Next
        If DisplayEmail = False Then
            '.Send
        End If
    End With
End Sub

代码用于确定哪些工作表必须导出为 pdf。
同时，我必须填写可以存储 PDF 的地图。
之后，代码启动 Outlook 项目并将 PDF 存储为附件。

Private Function sheetsArr(uF As UserForm) As Variant
    Dim c As MSForms.Control, strCBX As String, arrSh
    For Each c In uF.Controls
        If TypeOf c Is MSForms.CheckBox Then
            If c.Value = True Then strCBX = strCBX & "," & c.Caption
        End If
    Next
    sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function

第二个代码是根据值为true的复选框确定要导出哪些工作表。

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Answer 1

请将使用过的表单模块中的所有代码替换为下一个：

Option Explicit

Private Sub CommandButton1_Click()
 Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
 Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
 Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
 
 xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...

 For I = 0 To UBound(xArrShetts)
    On Error Resume Next
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    If xSht.Name <> xArrShetts(I) Then
        MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
    Exit Sub
    End If
 Next

 Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 If xFileDlg.Show = True Then
    xFolder = xFileDlg.SelectedItems(1)
 Else
    MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
    Exit Sub
 End If
 'Check if file already exist
 xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
 vbYesNo + vbQuestion, "File Exists")
 If xYesorNo <> vbYes Then Exit Sub
 For I = 0 To UBound(xArrShetts)
    Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
    
    xStr = xFolder & "\" & xSht.Name & ".pdf"
    xNum = 1
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
        xNum = xNum + 1
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)   'determine the last cell in A:A
        Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))  'create the range to be exported as pdf
        rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard 'export the range, not the sheet
    End If
    xArrShetts(I) = xStr
 Next

 'Create Outlook email
 Set xOutlookObj = CreateObject("Outlook.Application")
 Set xEmailObj = xOutlookObj.CreateItem(0)
 With xEmailObj
    .Display
    .To = ""
    .cc = ""
    .Subject = "????"
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If .DisplayEmail = False Then
        '.Send
    End If
 End With
End Sub

Private Function sheetsArr(uF As UserForm) As Variant
  Dim c As MSForms.Control, strCBX As String, arrSh
  For Each c In uF.Controls
        If TypeOf c Is MSForms.CheckBox Then
            If c.Value = True Then strCBX = strCBX & "," & c.Caption
        End If
  Next
  sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function

Private Sub CommandButton2_Click()
   Unload Me
End Sub

请在测试后发送一些反馈。