Question

我的目标是找到所有excel文件名和路径，以及所有PDF文件名和路径，并将它们编译到工作簿中（已完成）。然后在一个excel工作表上获取参考号，并使用同一工作表上列出的文件路径查找相应的excel文件。然后在同一工作簿中的其他两个工作表上查找相同的参考号，以找到对应的PDF的文件路径以及将这些文件发送到的电子邮件地址。然后创建电子邮件，附加文档，发送给列出的收件人。循环到下一行，直到完成。

我已经提取了所有的Excel和PDF信息并将其编译到工作表中。我认为下一步是尝试获取一个excel文件并创建一封发送给相应收件人的电子邮件。记下该代码后，我将在其上进行构建，然后找到适当的PDF并将其附加到电子邮件中。然后最后循环直到每一行完成。

我的问题是我无法附加一个excel文件和相应的电子邮件地址。 excel文件具有其自己的子文件夹，然后每个文件都有一个名为“ scans”的文件夹，最后是一个具有不同名称的.xlxs文件。我以为可以通过使用Set rngAttach = wb.Sheets("Folder Output").Range("B2").Value & "\Scans\"来完成此任务，然后再添加通配符扩展名.Attachments.Add Replace(rngAttach.Value, "*.xlxs", "") & strFileName。但是，这里出现一个错误，我的变量没有设置，但是我不确定我缺少什么。

这是我的完整代码，由于我走不远才能找到答案，因此可能无法正常工作。

Sub Email()

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Dim rngAttach As Range
Dim wb As ThisWorkbook
Dim wsEmail As Worksheet

Set wsEmail = wb.Sheets("Emails")

'Set range for file attachment
Set rngAttach = wb.Sheets("Folder Output").Range("B2").Value & "\Scans\"

strFileName = Dir(rngAttach.Value)

Application.ScreenUpdating = False

Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup

For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" Then
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = cell.Value
            .Subject = "Some Subject Line"
            .Body = "Dear "
           .Attachments.Add Replace(rngAttach.Value, "*.xlxs", "") & strFileName
            .Display  'Or use Send, Send will send the email without you seeing it, safer to use Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

有什么想法可以批准该代码吗？

我对此表示感谢。我到处都是站点，这就是我到现在为止获得代码的方式。

Excel查找多个文件并附加到电子邮件

0 个答案: