Question

我的编码经验很少。

我有代码在一个工作簿中读取发票编号作为范围c - W1 - 并从另一个工作簿中返回与发票费用和到期日相关的相应值 - W2。代码按预期运行。

我想使用相同的范围c来搜索Outlook中包含c值的主题行的已发送项目，并返回W1收件人的电子邮件地址和名字。

例如，可以显示发票编号＆＃34; 201x / xxxx＆＃34;，电子邮件的主题将显示为＆＃34; ABC Ltd的发票 - 201x / xxxx＆＃34;，代码将返回至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

Answer 1

此行olMail.Subject Like "*c*"正在查找主题行中包含字母 C 的电子邮件。从范围对象c中提取值：

Dim SearchFor As String
SearchFor = "*" & c.Value & "*"

If olMail.Subject Like SearchFor Then

在示例中，我使用string concatenation来构建搜索模式。我已经使用了一个单独的变量，尽管你没有。

您提到您的代码规模不断扩大并且变得混乱。这是一个常见问题。保持最佳状态的一种方法是将代码分解为许多较小的单元。粗略的例子：

' 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

确保每个子/功能都有一个，只有一个工作。给它一个有意义的名字，很快你就可以快速阅读你的代码，同时寻找合适的地方进行下一次更改。

修改

好的，所以我错过了OP代码中的一些重要细节。这是我重写的答案：

我添加了一个新功能，可以提取当前发票的电子邮件详细信息。

' 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。要更改此设置，您需要允许更多行或列。此外，电子邮件可能有多个收件人。这里提取的细节是第一个。您可以将它们全部提取到长字段或其他行/列中。

没有电子表格，我无法完全测试代码。新功能可能需要稍微调整一下;）。

如何通过Excel范围搜索Outlook项目主题以返回电子邮件地址？

1 个答案: