我的编码经验很少。
我有一个代码可以在一个工作簿中读取发票编号的范围c-W1- 并从另一个工作簿返回与发票费用和到期日期相关的相应值 -W2。代码按预期运行。
我想使用相同的范围c在Outlook中搜索包含c值的主题行的已发送邮件，并返回到收件人的电子邮件地址和姓名W1。
例如，发票编号可以显示"201x/xxxx"，电子邮件的主题将显示"ABC Ltd 的发票 - 201x/xxxx"，代码将返回以W1所需的数据。
我尝试应用Like函数。
下面是代码;
Sub UpdateDunningLog()
'defining source and target workbooks
Dim w1 As Worksheet, w2 As Worksheet
'c will be the matched value (invoice number)
Dim c As Range, FR As Long
'defining debtor log
Dim strfilename As String: strfilename = "xyz.xlsx"
Dim DL As Workbook
Application.ScreenUpdating = False
'sets active worksheet to Dunning Log
Set w2 = ActiveWorkbook.Sheets("Sheet1")
'sets debtor log to open (in background)
Set DL = Workbooks.Open(Filename:=strfilename, UpdateLinks:=3)
Set w1 = DL.Worksheets("Data")
Application.ScreenUpdating = False
'c is invoice number, macro begins reading at A4
' and continues until there are no remaining rows
For Each c In w1.Range("A4", w1.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
'matches invoice nummbers from debtor log to Dunning Log
FR = Application.Match(c, w2.Columns("E"), 0)
On Error GoTo 0
'if there is a match, client name is extracted
If FR <> 0 Then w2.Range("D" & FR).Value = c.Offset(0, 3)
'if there is a match, invoice value is extracted
If FR <> 0 Then w2.Range("G" & FR).Value = c.Offset(0, 15)
'if there is a match, overdue days are extracted
If FR <> 0 Then w2.Range("H" & FR).Value = c.Offset(0, 41)
Next c 'loops through each invoice number
Application.ScreenUpdating = True
'closes debtor log, ensuring it stays in the background throughout the process
DL.Close savechanges:=False
Dim olApp As Outlook.Application
Dim Folder As Outlook.MAPIFolder
Dim olNS As Namespace
Dim i As Integer, j As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim olMail As Object
MailBoxName = "xyz@xyz.xyz"
Pst_Folder_Name = "Sent Items"
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Folder = olNS.GetDefaultFolder(olFolderSentMail)
i = 1
For Each olMail In Folder.Items
If olMail.Subject Like "*c*" Then _
w2.Range("A" & FR).Value = Folder.Items.Item(i).RecipientName
If olMail.Subject Like "*c*" Then _
w2.Range("B" & FR).Value = Folder.Items.Item(i).RecipientEmailAddress
On Error GoTo 0
i = i + 1
Next olMail
End Sub
>此行olMail.Subject Like "*c*"查找主题行中包含字母C的电子邮件。 要从范围对象中提取值c：
Dim SearchFor As String
SearchFor = "*" & c.Value & "*"
If olMail.Subject Like SearchFor Then
在此示例中，我使用了字符串串联来构建搜索模式。 我使用了一个单独的变量，尽管您不必这样做。
你提到你的代码正在增长，变得混乱。 这是一个常见问题。 保持领先地位的一种方法是将代码分解为多个较小的单元。 粗略的例子：
' Code execution starts here.
Sub EntryPoint
Dim iNums As Range
Dim iNum As Range
Dim CurrentSubject As String
Set iNums = GetInvoiceNumbers()
For Each iNum In iNums
CurrentSubject = GetEmailSubject(iNum)
Next
End Sub
' Returns a list of invoice numbers.
Function GetInvoiceNumbers() As Range
' ...Code here...
End Function
' Checks Outlet mailbox.
Function GetEmailSubject(ByVal InvoiceNumber As String) As String
' ...Code here...
End Function
确保每个子/功能都有一个，并且只有一个作业。 给它起一个有意义的名字，很快你就能快速阅读你的代码，同时寻找正确的位置进行下一次更改。
编辑
好的，所以我错过了 OPs 代码中的一些重要细节。 这是我重新设计的答案：
我添加了一个新功能，用于提取当前发票的电子邮件详细信息。
' Checks the xyz mailbox for any items with the supplied
' invoice number in the sent items folder.
'
' InvoiceNumber Invoice to search for.
' RecipientNameCell Cell to write name to.
' RecipientEmailAddressCell Cell to write email address to.
Sub ExtractEmailDetails(ByVal InvoiceNumber As String, ByRef RecipientNameCell As Range, ByRef RecipientEmailAddressCell As Range)
Dim OlApp As Outlook.Application
Dim SentFolder As Outlook.MAPIFolder
Dim OlMail As Object
Set OlApp = New Outlook.Application
Set SentFolder = OlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
For Each OlMail In SentFolder.Items
' Ignore notes and other items that might be stored in the folder.
If TypeName(OlMail) = "MailItem" Then
If OlMail.Subject Like "*" & InvoiceNumber & "*" Then
RecipientNameCell.Value = OlMail.Recipients.Item(1).Name
RecipientEmailAddressCell = OlMail.Recipients.Item(1).Address
End If
End If
Next
End Sub
可以从代码中的现有循环调用它：
For Each c In w1.Range("A4", w1.Range("A" & Rows.Count).End(xlUp)) 'c is invoice number, macro begins reading at A4 and continues until there are no remaining rows
FR = 0
On Error Resume Next
FR = Application.Match(c, w2.Columns("E"), 0) 'matches invoice nummbers from debtor log to Dunning Log
On Error GoTo 0
If FR <> 0 Then w2.Range("D" & FR).Value = c.Offset(0, 3) 'if there is a match, client name is extracted
If FR <> 0 Then w2.Range("G" & FR).Value = c.Offset(0, 15) 'if there is a match, invoice value is extracted
If FR <> 0 Then w2.Range("H" & FR).Value = c.Offset(0, 41) 'if there is a match, overdue days are extracted
' NEW LINE BELOW.
ExtractEmailDetails c.Value, w2.Range("A" & FR).Value, w2.Range("B" & FR).Value
Next c 'loops through each invoice number
对于每个匹配的发票编号，ExtractEmailDetails执行一次。 它检查整个已发送框。 目前，如果找到超过 1 个匹配项，则仅将找到的姓氏/地址写入 Excel。 要更改此设置，您需要允许更多的行或列。 此外，一封电子邮件可以有多个收件人。 这里首先提取详细信息。 您可以将它们全部提取到长字段或其他行/列中。
没有电子表格，我无法完全测试代码。 新功能可能需要;)进行一些调整。