减少处理时间字符串分解

Question

我希望你能帮助我减轻我的代码的运行时间：

Dim position As Long 
Dim CellRow As Long 
CellRow = 2 

For position = InStr(Inbox.Items(MostRecentVersionIndex).body, "Name") To Len(Inbox.Items(MostRecentVersionIndex).body) 
      ThisWorkbook.Sheets(1).Range("A" & CellRow) = Mid(Inbox.Items(MostRecentVersionIndex).body, InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA"), InStr(InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA") + 1, Inbox.Items(MostRecentVersionIndex).body, "SCA") - InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA")) 
      CellRow = CellRow + 1 
      position = InStr(InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA") + 1, Inbox.Items(MostRecentVersionIndex).body, "SCA") - 1 
     Next position 

1. 代码的第一部分是找到Outlook中的特定电子邮件，然后我保存它的索引在MostRecentVersionIndex。 （未在上面显示）
2. 此电子邮件在其正文中有大量记录（约50万字符），而我的代码的第二部分（如上所示）则是将每条记录放入A列的新行中第1页。我知道每条记录都以“SCA”开头，这就是为什么我将它用作拆分参数的原因。

问题：需要（不出所料）大约10分钟来运行整个事情。

有关如何减少此问题的任何想法？

编辑：这里是FYI整个代码（用溶液更新后）：

Sub MailFinder() 
'1)Finding the most recent mail from Mr. Spoke 
    Dim Inbox As folder 
    Dim i As Integer 
    Dim MostRecentVersionIndex As Integer 
    MostRecentVersionIndex = -1 
    Dim TimeReceived As Date 
    Dim Content As String 
    Set Inbox = Session.GetDefaultFolder(olFolderInbox) 

    For i = 1 To Inbox.Items.Count 

      If TypeName(Inbox.Items(i)) <> "ReportItem" Then ' to avoid errors because we can't access information from this type of file 
       If Left(Inbox.Items(i).Subject, 24) = "Mr. Spoke Subject" Then 'And Inbox.Items(i).SenderName = "Mr.Spoke" Then 
         'MsgBox Len(Inbox.Items(i).body) '584512 
         If Inbox.Items(i).ReceivedTime > TimeReceived Then 
          TimeReceived = Inbox.Items(i).ReceivedTime 
          MostRecentVersionIndex = i 
         End If 
         'ThisWorkbook.Sheets("Sheet2").Range("A1") = Inbox.Items(i).body ' only get 32000 characters 

       End If 
      End If 
    Next i 

'2)Retrieving its information and storing each line in a new row from column A 
    Dim position As Long 
    Dim CellRow As Long 
    Dim RightMail As MailItem 
    Set RightMail = Inbox.Items(MostRecentVersionIndex) 
    Dim body As String 
    body = RightMail.body 
    CellRow = 2 
    If MostRecentVersionIndex <> -1 Then 
     ThisWorkbook.Sheets("SpokeSubject").Range("A1") = Left(body, InStr(body, "Name") + 3) 

     For position = InStr(body, "Name") To Len(body) 
      On Error GoTo Fin 
      ThisWorkbook.Sheets("SpokeSubject").Range("A" & CellRow) = Mid(body, InStr(position, body, "SCA"), InStr(InStr(position, body, "SCA") + 1, body, "SCA") - InStr(position, body, "SCA")) 
      CellRow = CellRow + 1 
      position = InStr(InStr(position, body, "SCA") + 1, body, "SCA") - 1 
     Next position '209333 
     'Inbox.Items(i).body.Copy ' doesn't work 
     'ThisWorkbook.Sheets("Sheet2").Range("A1").PasteSpecial 
     'ThisWorkbook.Sheets("Sheet2").Range("A1") = Inbox.Items(MostRecentVersionIndex).body ' all in one cell... 
Fin: 
    End If 
    Call Formatter 
End Sub 

Answer 1

这是采取极端的多个点表示法。先阅读该项目，然后阅读它的正文，然后才能遍历字符。

您需要认识到，每次您返回Items集合时，Outlook都会滚动到索引MostRecentVersionIndex，打开消息，然后读取其巨大的Body属性。你做这5到6次没有理由。

set Item = Inbox.Items(MostRecentVersionIndex) 
body = item.Body 
For position = InStr(body, "Name") To Len(body) 
      ThisWorkbook.Sheets(1).Range("A" & CellRow) = Mid(body, InStr(position, body, "SCA"), InStr(InStr(position, body, "SCA") + 1, body, "SCA") - InStr(position, body, "SCA")) 
      CellRow = CellRow + 1 
      position = InStr(InStr(position, body, "SCA") + 1, body, "SCA") - 1 
     Next position