保存从工作簿作为单独的PDF文件每个工作表

Question

我所拥有的是与所有从“手册”中的所有销售人员的销售工作簿，并在其他工作表的纸张由销售人员数（“41”命名， “51”，“88”等）与他们的销售。我想要的宏是把每个工作表，并保存为“工作表名称”&“文件名”

我的问题是与这篇文章，但由于某种原因，我的版本没有正确保存pdf的正确。

excel vba - save each worksheet in workbook as an individual pdf

所以我想要的东西很简单：取每个工作表，并保存到它自己的独特的PDF格式。我遇到的问题是，宏节约用正确的文件名每一个人片，但是当我打开PDF格式，它同销售人员为每个PDF文件。

这里是代码：

Option Explicit 

Sub WorksheetLoop() 

Dim wsA  As Worksheet 
Dim wbA  As Workbook 
Dim strTime As String 
Dim strName As String 
Dim strPath As String 
Dim strFile As String 
Dim strPathFile As String 
Dim myFile As Variant 
Dim WS_Count As Integer 
Dim I  As Integer 

' Set WS_Count equal to the number of worksheets in the active workbook. 
Set wbA = ActiveWorkbook 
WS_Count = wbA.Worksheets.Count 
strPath = wbA.Path 
strTime = Format(Now(), "yyyymmdd\_hhmm") 

'get active workbook folder, if saved 
strPath = wbA.Path 
If strPath = "" Then 
    strPath = Application.DefaultFilePath 
End If 
strPath = strPath & "\" 

' Begin the loop. 
For I = 1 To WS_Count 

    'replace spaces and periods in sheet name 
    strName = Replace(wbA.Worksheets(I).Name, " ", "") 
    strName = Replace(strName, ".", "_") 

    'create default name for savng file 
    strFile = strName & "_" & strTime & ".pdf" 
    myFile = strPath & strFile 

    Debug.Print myFile 

    'export to PDF if a folder was selected 
    If myFile <> "False" Then 
     ActiveSheet.ExportAsFixedFormat _ 
       Type:=xlTypePDF, _ 
       Filename:=myFile, _ 
       Quality:=xlQualityStandard, _ 
       IncludeDocProperties:=True, _ 
       IgnorePrintAreas:=False, _ 
       OpenAfterPublish:=False 
     'confirmation message with file info 
     MsgBox "PDF file has been created: " _ 
       & vbCrLf _ 
       & myFile 
    End If 

Next I 

End Sub 

让我知道如果你需要任何额外的细节

Answer 1

您需要激活Activate每个工作表打印它们转换成PDF之前。试试这个

' Begin the loop. 
    For Each wsA In wbA.Sheets 

     wsA.Activate 
     'replace spaces and periods in sheet name 
     strName = Replace(wsA.Name, " ", "") 
     strName = Replace(strName, ".", "_") 

     'create default name for savng file 
     strFile = strName & "_" & strTime & ".pdf" 
     myFile = strPath & strFile 

     Debug.Print myFile 

     'export to PDF if a folder was selected 
     If myFile <> "False" Then 
      ActiveSheet.ExportAsFixedFormat _ 
         Type:=xlTypePDF, _ 
         Filename:=myFile, _ 
         Quality:=xlQualityStandard, _ 
         IncludeDocProperties:=True, _ 
         IgnorePrintAreas:=False, _ 
         OpenAfterPublish:=False 
      'confirmation message with file info 
      MsgBox "PDF file has been created: " _ 
       & vbCrLf _ 
       & myFile 

     End If 

    Next 

Answer 2

您应该首先激活每张纸，然后再导出为PDF格式。请尝试：

Option Explicit 

Sub WorksheetLoop() 

Dim wsA  As Worksheet 
Dim wbA  As Workbook 
Dim strTime As String 
Dim strName As String 
Dim strPath As String 
Dim strFile As String 
Dim strPathFile As String 
Dim myFile As Variant 
Dim WS_Count As Integer 
Dim I  As Integer 

' Set WS_Count equal to the number of worksheets in the active workbook. 
Set wbA = ActiveWorkbook 
WS_Count = wbA.Worksheets.Count 
strPath = wbA.Path 
strTime = Format(Now(), "yyyymmdd\_hhmm") 

'get active workbook folder, if saved 
strPath = wbA.Path 
If strPath = "" Then 
    strPath = Application.DefaultFilePath 
End If 
strPath = strPath & "\" 

' Begin the loop. 
For Each wsA In wbA.Worksheets 
    wsA.Activate 
    'replace spaces and periods in sheet name 
    strName = Replace(wsA.Name, " ", "") 
    strName = Replace(strName, ".", "_") 

    'create default name for savng file 
    strFile = strName & "_" & strTime & ".pdf" 
    myFile = strPath & strFile 

    Debug.Print myFile 

    'export to PDF if a folder was selected 
    If myFile <> "False" Then 
     ActiveSheet.ExportAsFixedFormat _ 
       Type:=xlTypePDF, _ 
       Filename:=myFile, _ 
       Quality:=xlQualityStandard, _ 
       IncludeDocProperties:=True, _ 
       IgnorePrintAreas:=False, _ 
       OpenAfterPublish:=False 
     'confirmation message with file info 
     MsgBox "PDF file has been created: " _ 
       & vbCrLf _ 
       & myFile 
    End If 

Next wsA 

End Sub