带有特定单词的电子邮件附件

Question

我想从特定文件夹（路径）添加附件我正在寻找宏以从 D 列中获取附件名称，但只有最后一个单词作为文件夹中的附件将只包含给定文件夹中的最后一个单词。

例如。在 D2 宏中将在指定文件夹中搜索单词“QR”并添加附件。

Sub SendMultipleEmailsaa()

Dim Mail_Object, OutApp As Object
Dim ws As Worksheet: Set ws = ActiveSheet
Dim arr() As Variant

LastRow = ws.Cells(ws.Rows.Count, "b").End(xlUp).Row

ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=ws.Range("A2:A" & LastRow),         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange ws.UsedRange
.Header = False
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

arr = ws.Range("A2:A" & LastRow)

 Set Mail_Object = CreateObject("Outlook.Application")

first = 2

For i = LBound(arr) To UBound(arr)


If i = UBound(arr) Then GoTo YO
If arr(i + 1, 1) = arr(i, 1) Then
            first = WorksheetFunction.Min(first, i + 1)
Else
YO:
Set OutApp = Mail_Object.CreateItem(0)

With OutApp
     .Subject = ws.Range("C" & i + 1).Value
     .Body = "Your message here"
     .Display
     .To = ws.Range("B" & i + 1).Value
     For j = first To i
        .Recipients.Add ws.Range("B" & j).Value
     Next
     first = i + 2

End With
End If

Next

End Sub

Answer 1

更改这部分代码：

With OutApp
     .Subject = ws.Range("C" & i + 1).Value
     .Body = "Your message here"
     .Display
     .To = ws.Range("B" & i + 1).Value
     For j = first To i
        .Recipients.Add ws.Range("B" & j).Value
     Next
     first = i + 2

End With

与：

pth = "F:\WIN7PROFILE\Desktop\File\"
With OutApp
     .Subject = ws.Range("C" & i + 1).Value
     .Body = "Your message here"
     .Display
     .To = ws.Range("A" & i + 1).Value
     .Attachments.Add pth & Dir(pth & "*" & Replace(ws.Range("D" & i + 1).Value, "File - Fund ", "") & "*")
     For j = first To i
        .Recipients.Add ws.Range("A" & j).Value
     Next
     first = i + 2

End With