減少處理時間字符串分解

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