如何修改Excel VBA代码实现横向导出适配动态范围的单页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))
    
    xNum = 1
    xStr = xFolder & "\" & xSht.Name & "_" & Sheets("Voorblad").Range("D24").Value & ".pdf"
    '修复重复文件命名逻辑
    While Not (Dir(xStr, vbDirectory) = vbNullString)
        xStr = xFolder & "\" & xSht.Name & "_" & Sheets("Voorblad").Range("D24").Value & "_" & xNum & ".pdf"
        xNum = xNum + 1
    Wend
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        '新增页面设置代码，配置导出PDF规则
        With xSht.PageSetup
            .Orientation = xlLandscape '设置横向导出
            .Zoom = False '关闭手动缩放，才能启用自适应页数配置
            .FitToPagesWide = 1 '所有列适配到1页宽度
            .FitToPagesTall = 1 '所有行适配到1页高度，如果不需要限制行高可改为False
            .PrintArea = xUsedRng.Address '指定打印范围为工作表已使用区域
            .CenterHorizontally = True '可选：内容水平居中
        End With
        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

可选调整说明 #

如果工作表内容行数过多，强制压缩到1页会导致字体过小，可将.FitToPagesTall = 1修改为.FitToPagesTall = False，仅保证宽度适配到1页，高度根据内容自动分页。

内容的提问来源于stack exchange，提问作者Thom Haasert