以橫向和動態范圍保存 PDF

Question

在很多幫助下，我設法制作了一個用戶表單，我可以在其中選擇要導出為 PDF 的工作表。 之后，它會自動將創建的 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 & "_" & Sheets("Voorblad").Range("D24").Value & ".pdf"
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & xNum & ".pdf"
    xNum = 100
       
    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 = "Administratie@holwerda.nl"
    .CC = "Jaap@holwerda.nl;Gerben@holwerda.nl;Peter@holwerda.nl"
    .Subject = Sheets("Voorblad").Range("B24").Value & "_" & Sheets("Voorblad").Range("D24").Value
    
    
    
    
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If DisplayEmail = False Then
        '.Send
    End If
End With
Unload Me
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

我想以橫向樣式和動態范圍導出 PDF。 現在，當我導出文件時，有時它不適合一頁。

Answer 1

@faneDuru，@Raymond Wu 我試過你的解決方案，我認為它有效。

我已經將代碼改寫如下：

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 & "_" & Sheets("Voorblad").Range("D24").Value & ".pdf"
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & xNum & ".pdf"
    xNum = 100
       
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    xSht.PageSetup.Orientation = xlLandscape
    xSht.PageSetup.FitToPagesTall = 1
    xSht.PageSetup.PrintArea = "$A$1:$J$30"
        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 = "Administratie@holwerda.nl"
    .CC = "Jaap@holwerda.nl;Gerben@holwerda.nl;Peter@holwerda.nl"
    .Subject = Sheets("Voorblad").Range("B24").Value & "_" & Sheets("Voorblad").Range("D24").Value
    
    
    
    
    For I = 0 To UBound(xArrShetts)
        .Attachments.Add xArrShetts(I)
    Next
    If DisplayEmail = False Then
        '.Send
    End If
End With
Unload Me
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