导出适合一页的 PDF

Question

我正在使用以下代码导出某些工作表。当我导出文件时，工作表不适合单独一页 (A4)。我希望导出以 PDF 格式单独导出，使它们适合一张纸。

代码如下：

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 = "Administratie@holwerda.nl"
        .cc = "Gerben@holwerda.nl"
        .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

Answer 1

请尝试下一个代码：

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
        With xSht.PageSetup
              .PaperSize = xlPaperA4
              .PrintArea = rngExp.Address(0, 0)
              .Orientation = xlLandscape
              .FitToPagesWide = 1
              .FitToPagesTall = 1
        End With
        rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False  '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

您应该只替换 CommandButton1_Click() 子代码。