在excel中生成可变数量工作表的PDF并通过电子邮件发送

Posted 2023-02-24

【中文标题】在excel中生成可变数量工作表的PDF并通过电子邮件发送

【英文标题】：Generate PDF of variable number of sheets in excel and send by email

【发布时间】：2022-01-04 13:57:11

【问题描述】：

我可以使用你们的一些帮助来调试我的 VBA 代码以通过电子邮件发送 pdf。 excel 工作表是可变的（有时会添加一些，有时会删除一些），其名称存储在称为 Projetos 的其他工作表中。 在我尝试选择工作表（使用数组）之前，我的代码似乎运行良好，目前我遇到了 Run.time 错误 9 - 下标超出范围。但是，如果我在 Array 中手动引入工作表名称，则代码可以完美地完成所有工作。提前感谢您的支持，我确定这是基本的东西

Sub Send_PDF_Email()

Dim wPath As String, wFile As String, pets As Variant, myArray As Variant, yourArray As String    

R = 5
Do While Not IsEmpty(Sheets("Projetos").Cells(R, 2))
    R = R + 1
Exit Do
Loop

    pets = Worksheets("Projetos").Range("B5:B" & R).Value
    myArray = Application.Transpose(pets)
    yourArray = Join(myArray, " , ")
       
     
ThisWorkbook.Sheets(yourArray).Select
'ThisWorkbook.Sheets(Array("2070507", "2070614")).Select
    
    wPath = ThisWorkbook.Path
    wFile = "DadosRPO.pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=wPath & wFile, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
    On Error GoTo 0

       
    
    Set dam = CreateObject("Outlook.Application").CreateItem(0)

    dam.To = Sheets("Projetos").Cells(28, 3).Value
    dam.Subject = "Dados RPO"
    dam.Body = "Seguem os dados referentes aos projectos em execução"
    dam.Attachments.Add wPath & wFile
    dam.Send

End Sub

【问题讨论】：

你需要选择一个真正的数组myArray而不是一个字符串yourArray：试试ThisWorkbook.Sheets(myArray).Select

【参考方案1】：

谢谢你们。我终于能够正常运行我的代码了。

Sub Send_PDF_Email()
Dim wPath As String, wFile As String, myArray() As String

'################ SHEETS TO PDF #######################

 R = 5
 Do While Not IsEmpty(Sheets("Projetos").Cells(R, 2))
 R = R + 1
 Loop

 cpt = 0
 ReDim myArray(1 To R - 5)

 For x = 5 To R - 1
 cpt = cpt + 1
 myArray(cpt) = Worksheets("Projetos").Range("B" & x).Value
 
 Next x

 '#####################  PDF ################

 ThisWorkbook.Sheets(myArray).Select


 wPath = ThisWorkbook.Path
 wFile = "DadosRPO.pdf"
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=wPath & wFile, 
 Quality:=xlQualityStandard, IncludeDocProperties:=False, 
 IgnorePrintAreas:=False, OpenAfterPublish:=False
 On Error GoTo 0

'####################  EMAIL ####################

Set dam = CreateObject("Outlook.Application").CreateItem(0)

dam.To = Sheets("Projetos").Cells(28, 3).Value
dam.Subject = "Dados RPO"
dam.Body = "Seguem os dados referentes aos projectos em execu��o"
dam.Attachments.Add wPath & wFile
dam.Send

Worksheets("Projetos").Activate


End Sub

【参考方案2】：

你只需要这样做：

cpt=0
For x = 5 To R
     cpt = cpt + 1
     ReDim Preserve MyArray (cpt)
     MyArray (cpt) = Worksheets("Projetos").Range("B" & x ).value
Next x
ThisWorkbook.Sheets(MyArray).Select

或者像 PEH 所说的那样没有循环：

ThisWorkbook.Sheets(MyArray).Select

而不是：

ThisWorkbook.Sheets(yourArray).Select

如果上述方法不起作用，我认为您需要： 显示存储在数组中的所有值，并检查它们是否与工作表名称具有相同的值。

【讨论】：

yourArray = Join(myArray, ",") 不适用于选择Sheets，因为Sheets() 需要一个带有一张表确切名称的String，一个带有制表符位置编号的Long，或者一维Array，其中每一项都是确切一张纸的名称。 • Join 使用逗号分隔的工作表名称创建String，并且不起作用。

@Pᴇʜ 我认为我的答案的第一部分将使他的代码有效

是的，它解决了这个问题，但是单独使用 ThisWorkbook.Sheets(MyArray).Select 的原始代码已经可以工作了，因为 Application.Transpose(pets) 将您从 pets = Worksheets("Projetos").Range("B5:B" & R).Value 获得的值的二维数组转换为您可以使用的一维数组直接在ThisWorkbook.Sheets(MyArray).Select中使用。所以不需要循环。

@Pᴇʜ 谢谢你完整的回答你的建议

但是当我只使用 ´myArray = Application.Transpose(pets)` 然后 ThisWorkbook.Sheets(MyArray).Select 我也得到订阅超出范围