如何解决通过在电子邮件正文中查找特定的字符串来循环浏览Outlook电子邮件以更新excel电子表格
我试图在Outlook中循环浏览已发送的文件夹，并用电子邮件的“接收时间”更新我的电子表格。我的电子表格有一个包含记录号的列，每封电子邮件都包含一个或多个记录号，如果电子邮件正文具有匹配的记录，那么我想提取接收到的日期并将其放在一列中，我相信问题出在我的If语句中：
Option Explicit
Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
' Set Outlook application object.
Dim objOutlook As Object
Set objOutlook = CreateObject("outlook.application")
Dim objNSpace As Object ' Create and Set a NameSpace OBJECT.
' The GetNameSpace() method will represent a specified Namespace.
Set objNSpace = objOutlook.GetNamespace("MAPI")
Dim myFolder As Object ' Create a folder object.
Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)
Dim objItem As Object
Dim iRows,iCols As Integer
Dim sFilter As String
iRows = 2
Dim MyRange As Range
Dim cell As Range
Dim Wb As Workbook
Dim FiltRange As Range
Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Activate
'Set MyRange = Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Worksheets("Data").Range(Cells(1,1).Offset(1,0),Range("A1").End(xlDown))
' select the records in column A
Set MyRange = Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Worksheets("Data").Range(Cells(2,1),Range("A1").End(xlDown))
'Debug.Print MyRange.Address
'only select the filtered records
Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)
'Debug.Print FiltRange.Address
'create a filter for emails marked as not completed
sFilter = "[Categories] = 'Not Completed'"
'Debug.Print sFilter
ThisWorkbook.Sheets("Sent_Email").Activate
' Loop through each item in the folder.
'Debug.Print myFolder.Items.Restrict(sFilter).Count
'loop through the emails in the sent folder restricted to specific category
For Each objItem In myFolder.Items.Restrict(sFilter)
If objItem.Class = olMail Then
Dim objMail As Outlook.MailItem
Set objMail = objItem
'extract data from email
Cells(iRows,1) = objMail.Recipients(1)
Cells(iRows,2) = objMail.To
Cells(iRows,3) = objMail.Subject
Cells(iRows,4) = objMail.ReceivedTime
Cells(iRows,5) = objMail.Body
'If MyRange <> "" Then
'loop throug the records on the spreadsheet to find matches
For Each cell In FiltRange
'Debug.Print MyRange.Find(cell.Value)
'Debug.Print cell.Value
'Debug.Print Cells(iRows,5)
'if the email body contain the matching record or specific string then copy the received time to the row for the matching record
If InStr(LCase(Cells(iRows,5)),cell.Value > 0) And InStr(LCase(Cells(iRows,LCase("GTPRM")) > 0 Then
Debug.Print cell.Value
cell(,35).Value = Cells(iRows,4).Value
End If
Next cell
'End If
End If
iRows = iRows + 1
Next
Set objMail = nothing
' Release.
Set objOutlook = nothing
Set objNSpace = nothing
Set myFolder = nothing
ErrHandler:
Debug.Print Err.Description
End Sub
解决方法
正如我在评论中所说，我无法解释为什么您的问题陈述失败而没有看到您的数据。相反，我将找出使您的代码更可能失败并且更难以诊断的问题。
出现错误时转到TorrHandler
我看到应该更了解的作者使用了此声明。我无法想象这种情况在开发过程中会有所帮助。如果有问题，我希望在导致问题的语句上停止执行。我不想从错误描述中猜测哪个语句导致了问题。通过操作宏来确定最佳方法更加困难。
有两种类型的运行时错误：可以避免的错误和无法避免的错误。您可以避免的错误示例包括数组绑定错误和被零除。您将在测试期间尝试消除此类错误，但是始终存在您不允许的罕见错误的风险。您的选择是让执行停止在给出错误的语句或跳转到错误处理程序。有吸引力的主张也不是。该代码将停止在某些事情的中间，而导致正常失败的可能性很小。我的用户一直以来都这样，我可以在执行停止时留下有关记录内容和调用者的详细说明，因此我不必考虑错误处理程序。
无法避免的错误示例是尝试打开您没有必要访问权限的文件。为了处理这种情况，我建议使用以下代码：
Dim ErrDesc As String
Dim ErrNum As Long
:
Err.Clear
On Error Result Next
Statement that might fail
ErrNum = Err.Number
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum <> 0 Then
Code to handle failure
End If
此例程中使用了此技术的一种变体：
Public Function WshtExists(ByRef Wbk As Workbook,ByVal WshtName As String) As Boolean
' Returns True if Worksheet WshtName exists within
' * if Wbk Is Nothing the workbook containing the macros
' * else workbook Wbk
Dim WbkLocal As Workbook
Dim Wsht As Worksheet
If Wbk Is Nothing Then
Set WbkLocal = ThisWorkbook
Else
Set WbkLocal = Wbk
End If
Err.Clear
On Error Resume Next
Set Wsht = WbkLocal.Worksheets(WshtName)
On Error GoTo 0
If Wsht Is Nothing Then
WshtExists = False
Else
WshtExists = True
End If
End Function
这是我用来检查工作簿中是否存在工作表的例程。我本可以使用For-Loop循环浏览工作簿的工作表，从而避免使用On Error Resume Next。但是，按循环方法要慢得多。我不会经常检查工作表的存在以至于节省时间，但我更喜欢此代码。您可能更喜欢循环使用方法。
变量声明的放置
如果在子例程或函数之外编写Public A As Long ，则工作簿中任何模块内的任何子例程或函数都可以访问变量A。
如果在子例程或函数外部编写Dim A As Long ，则同一模块内的任何子例程或函数均可访问变量A。
如果在子例程或函数中编写Dim A As Long ，则同一子例程或函数中的任何语句都可以访问变量A。
放置声明的位置，确定变量的作用域。这是VBA的三个选择：公共，模块本地和例程常规。我听到抱怨说，很难找到可变范围的定义。有些语言具有附加范围，但不适用于VBA。
您已经在例程中首次使用变量之前声明了变量。我已经读过论点，认为这是最好的方法。我更喜欢将所有声明按字母顺序放在例程的顶部。当我在写完例行程序后的六到十二个月返回例行程序时，可以在顶部找到所有的声明和解释。我觉得这很有帮助，但可以选择。
将变量声明为对象
将变量声明为对象称为后期绑定。编译器不知道将在变量中放置哪种类型的对象。在运行时设置变量时，解释器会发现类型。
替代方法是引用Outlook库。在VBA编辑器中，单击[工具]，然后单击[参考...]。这将显示数百个库的列表，这些库定义了可用于工作簿的变量类型和例程。这样的库之一就是“ Microsoft Outlook nn.0对象库”，其中nn取决于您使用的Office版本。选中此库右侧的框。由于您在代码中使用了Outlook.MailItem，因此您可能已经对此感到失望了。
如果我引用Outlook对象库，则可以编写：
Dim objOutlook As Outlook.Application
Dim objNSpace As Namespace
Dim myFolder As Outlook.Folder
我发现声明将要放置在变量中的对象的类型很有帮助。这称为早期绑定。您可以在网上找到有关早装和晚装的优点的讨论。
您写正确的Dim objItem As Object是正确的。 “已发送文件夹”将不太可能包含MailItems以外的任何其他内容，但是有可能。像您一样测试objItem的类是谨慎的。
将iRows，iCols设置为整数
对于大多数语言，Integer和Long类型的变量的大小取决于目标计算机的字长。使用VBA，整数是16位，而Long是32位。我已经读到32和64位PC上的Integer变量要比Long变量慢，因为它们需要特殊处理。我在计时上的尝试并没有发现任何差异。整数中可以保留的最大值为65,535。工作表可以有1,048,576行，因此保存行号的变量应为Long。我将所有整数变量都声明为Long，因为它没有明显的缺点，并且减少了溢出的机会。
设置objOutlook = CreateObject（“ Outlook.Application”）
我使用以下代码从Excel中打开和关闭Outlook：
Dim AppOut As Outlook.Application
Dim Created As Boolean
Dim OutNs As Outlook.Namespace
Set AppOut = OutAppGetCreate(Created)
Set OutNs = AppOut.Session
Code accessing Outlook
Call OutAppClose(AppOut,Created)
OutAppGetCreate()中的评论解释了原因：
Public Sub OutAppClose(ByRef OutApp As Outlook.Application,ByVal Created As Boolean)
' If Created is True,quit the current instance of Outlook.
If Created Then
OutApp.Quit
End If
Set OutApp = Nothing
End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application
' Return a reference to the Outlook Application.
' Set Created to True if the reference is to a new application and to
' False if the reference is to an existing application.
' If Nothing is returned,the routine has been unable to get or create a reference.
' Only one instance of Outlook can be running. CreateObject("Outlook.Application")
' will return a reference to the existing instance if one is already running or
' will start a new instance if one is not running. The disadvantage of using
' CreateObject,is the caller does not know if Outlook was running so does not know
' whether or not to quit Outlook when it has finished using Outlook. By setting
' Created,this routine allows the caller to only quit if this is appropriate.
Set OutAppGetCreate = Nothing
On Error Resume Next
Set OutAppGetCreate = GetObject(,"Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
On Error Resume Next
Set OutAppGetCreate = CreateObject("Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
Call MsgBox("I am unable to access Outlook",vbOKOnly)
Exit Function
End If
Created = True
Else
Created = False
End If
End Function
设置myFolder = objNSpace.GetDefaultFolder（olFolderSentMail）
我无法在笔记本电脑上使用GetDefaultFolder。我有几个电子邮件地址，每个地址都有一个商店，外加默认商店“ Outlook数据”。这是向导创建的默认Outlook安装。这些存储中的每一个都有自己的“收件箱”和“已发送”文件夹。 “ {Outlook}”中的空白是GetDefaultFolder返回的默认值。
如果使用的是工作安装，则可能只有一个商店，而默认的已发送文件夹就是您所期望的文件夹。如果您担心收到的发送文件夹错误，请尝试Debug.Print myFolder.Parent.Name。
工作簿（“具有LOB的RIRQ和RRTN，2020年9月28日”）。激活 ThisWorkbook.Sheets（“ Sent_Email”）。激活
标准建议是避免使用Activate。给出的主要原因是它是一种缓慢的方法。当然，如果您使用Activate在工作簿或工作表之间进行切换，则可以显着增加宏的持续时间。如果您像这样做一样省略Application.ScreenUpdating = False，则尤其如此，因为每次更新当前工作表或切换工作簿或工作表时都会重新绘制屏幕。我避免使用Activate，因为它使识别当前工作簿和工作表变得很困难。
如果您写：
With Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Activate
Set MyRange =.Worksheets("Data") .Range(Cells(2,1),Range("A1").End(xlDown))
End With
With ThisWorkbook
With .Sheets("Sent_Email")
:
.Cells(iRows,1) = objMail.Recipients(1)
:
End With
End With
您可以查询上一个With语句，以识别正在访问哪个工作表或工作簿。使用您的方法，您必须检查是否有语句将当前工作簿或工作表更改为副作用。您还必须担心子例程会更改当前工作簿或工作表。
.Range（“ A1”）。End（xlDown）
这等效于将光标定位到单元格A1，然后单击Ctrl + Down。如果A列数据的中间有一个空白单元格，它将在第一个空白单元格上方的单元格处停止。
推荐使用End为.Cells(Rows.Count,1).End(xlUp)。这在最后一个非空白单元格处停止。
'Debug.Print MyRange.Address
'Debug.Print FiltRange.Address
我在开发过程中大量使用了Debug.Print和Debug.Assert`，因此我同意。但是，直到我使代码正常工作，我才会注释掉这些声明。
设置FiltRange = MyRange.SpecialCells（xlCellTypeVisible）
此语句试图实现什么？您是否确实在A列中有隐藏的单元格？您是否要失去空白细胞？空白单元格可见。如果需要的话，可以消除空白单元格。
如果MyRange中的每个非空白单元格都是一个值，请使用：
Set FiltRange = MyRange.SpecialCells(xlCellTypeConstants)
如果MyRange中的每个非空白单元格都是一个公式，请使用：
Set FiltRange = MyRange.SpecialCells(xlCellTypeFormulas)
如果MyRange是值的混合，则使用公式和空格：
Union(MyRange.SpecialCells(xlCellTypeConstants),_
MyRange.SpecialCells(xlCellTypeFormulas))
如果InStr（LCase（Cells（iRows，5）），cell.Value> 0）和_
InStr（LCase（Cells（iRows，5）），LCase（“ GTPRM”））> 0然后
我认为这会更清楚：
If InStr(LCase(objMail.Body),cell.Value > 0) And _
InStr(LCase(objMail.Body),("gtprm")) > 0 Then
或更妙的是：
LcBody = LCase(objMail.Body) 'Outside loop
:
If InStr(LcBody,cell.Value > 0) And _
InStr(LcBody,("gtprm")) > 0 Then
只是在简化之后，我才注意到该声明应该是：
If InStr(LcBody,cell.Value) > 0 And _
InStr(LcBody,("gtprm")) > 0 Then
或
If InStr(LCase(Cells(iRows,5)),cell.Value) > 0 And
InStr(LCase(Cells(iRows,LCase("GTPRM")) > 0 Then
Private Sub Follow_Up_Update()
'On Error GoTo ErrHandler
' Set Outlook application object.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objNSpace As Object ' Create and Set a NameSpace OBJECT.
' The GetNameSpace() method will represent a specified Namespace.
Set objNSpace = objOutlook.GetNamespace("MAPI")
Dim myFolder As Object ' Create a folder object.
Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)
Dim RangeObject As Range
Dim objItem As Object
Dim iRows,iCols As Integer
Dim sFilter As String
iRows = 2
Dim MyRange As Range
Dim cell As Range
Dim WB As Workbook
Dim FiltRange As Range
Dim Lcbody As String
Dim RIRQWorkbbok As Workbook
Dim Sup_Number As Range
Dim objMail As Outlook.MailItem
Dim Sent_Email As Workbook
Dim Data As Range
Dim StringData As String
Dim CellContent As Range
Dim Range_SentEmail As Range
Dim answer As Integer
Dim sFilter_porfolio As String
Dim answer_RiRQ As String
'filter out data
'Tracker_Filter
Dim Range_RIRQ As Range
'Set Sent_Email = ThisWorkbook
Debug.Print ThisWorkbook.Name
With ThisWorkbook.Worksheets("Sent_Email")
.Activate
Set Range_SentEmail = .Range("E2",Range("E2").End(xlDown))
End With
'Debug.Print Sent_Email.Address
Application.ScreenUpdating = False
'prompt user to select a file
answer = MsgBox("Do you want to Open RIRQ/RRTN tracker?",vbYesNoCancel,"Select file")
If answer = vbYes Then
FileOpenDialogBox
Else
MsgBox "you haven't selected a file !"
Exit Sub
End If
'Debug.Print ActiveWorkbook.Name
'Tracker_Filter
'activate the worksheet "Data" on the newly opened workbook
With ActiveWorkbook.Worksheets("Data")
.Activate
'add a header to the column that will contain extracted data from the sent emails folder
.Cells(1,36).Value = "Reach outs Date"
'filter only the RRTN and RIRQs programs
Tracker_Filter
'set a reference to the cells on the active sheet
Set MyRange = .Range(Cells(2,Range("A1").End(xlDown))
End With
'set a reference to the visible cells on filtered activesheet
Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)
'Debug.Print FiltRange.Address
'create a filter based on folder categorie "not Completed" and subject line "Action required: Portfolio Reassessment"
sFilter = "[Categories] = 'Not Completed' And [Subject] = 'Action required: Portfolio Reassessment'"
sFilter_porfolio = "[Categories] = 'Not Completed' And [Subject] = 'Urgent: SEMS Portfolio Reassessment: Phase 1'"
'Debug.Print sFilter
'loop through the sent emails folder and write the data to the sheet called "Sent_Email"
If ThisWorkbook.Sheets("Sent_Email").Cells(2,1) = "" Then
For Each objItem In myFolder.Items.Restrict(sFilter)
If objItem.Class = olMail Then
Set objMail = objItem
With ThisWorkbook.Sheets("Sent_Email")
.Cells(iRows,1) = objMail.Recipients(1)
'.Cells(iRows,2) = objMail.To
.Cells(iRows,3) = objMail.Subject
.Cells(iRows,4) = objMail.ReceivedTime
.Cells(iRows,5) = objMail.Body
.Cells(iRows,6) = ResolveDisplayNameToSMTP(objMail.Recipients(1))
'End With
End With
End If
iRows = iRows + 1
Next objItem
End If
'
'ask user if they want to extract dates when emails were seent
answer_RiRQ = MsgBox("Do you want to update RRTN/RRIQs reach outs dates?","RRTN/RIRQ")
If ThisWorkbook.Sheets("RIRQ-RRTN_emails").Cells(2,1) = "" Then
If answer = vbYes Then
iRows = 2
For Each objItem In myFolder.Items.Restrict(sFilter_porfolio)
If objItem.Class = olMail Then
Set objMail = objItem
With ThisWorkbook.Sheets("RIRQ-RRTN_emails")
.Cells(iRows,1) = objMail.Recipients(1)
'.Cells(iRows,2) = objMail.To
.Cells(iRows,3) = objMail.Subject
.Cells(iRows,4) = objMail.ReceivedTime
.Cells(iRows,5) = objMail.Body
.Cells(iRows,6) = ResolveDisplayNameToSMTP(objMail.Recipients(1))
'End With
End With
End If
iRows = iRows + 1
Next objItem
Else
MsgBox "script will continue to run!"
End If
End If
'activate the worksheet where the data was written based on the filter : sFilter_porfolio
With ThisWorkbook.Worksheets("RIRQ-RRTN_emails")
.Activate
'set a reference to the cells that contain data extracted based on filter called sFilter_porfolio
Set Range_RIRQ = .Range("E2",Range("E2").End(xlDown))
End With
For Each cell In FiltRange
cell.Offset(,12).Value = Trim(cell.Offset(,12).Value)
'write to the main sheet based on the condition
For Each Data In Range_RIRQ
'
If InStr(Data.Value,cell.Value) > 0 Then
cell.Offset(,36).Value = "Esccalation note sent on " & Data.Offset(,-1).Value
'Debug.Print cell.Offset(,35).Value
'Debug.Print cell.Offset(,35)
End If
Next Data
'Next cell
Application.ActiveSheet.Columns("AK:AK").AutoFit
'End If
For Each Data In Range_SentEmail
'
'write to the main sheet based on the condition
If InStr(Data.Value,35).Value = "first communication sent on " & Data.Offset(,-1).Value
End If
Next Data
Next cell
Application.ActiveSheet.Columns("AJ:AJ").AutoFit
Application.ScreenUpdating = True
Set objMail = Nothing
' Release.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
'ErrHandler：
'Debug.Print Err.Description
结束子
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
