Excel宏内存不足错误

Question

真的很希望得到一些帮助！

，我会说我没有写这个代码开始（有人远远聪明然后我做到了！）

如果任何人都可以在此提供一些线索，将不胜感激。它确实运行了一段时间，但是当我们扩大规模时，我开始遇到问题。

，我遇到了错误与整个代码：

Option Explicit 

Public ns As Outlook.Namespace 

Private Const EXCHIVERB_REPLYTOSENDER = 102 
Private Const EXCHIVERB_REPLYTOALL = 103 
Private Const EXCHIVERB_FORWARD = 104 

Private Const PR_LAST_VERB_EXECUTED =  "http://schemas.microsoft.com/mapi/proptag/0x10810003" 
Private Const PR_LAST_VERB_EXECUTION_TIME =  "http://schemas.microsoft.com/mapi/proptag/0x10820040" 
Private Const PR_SMTP_ADDRESS =  "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
Private Const PR_RECEIVED_BY_ENTRYID As String =  "http://schemas.microsoft.com/mapi/proptag/0x003F0102" 

' Locates best matching reply in related conversation to the given mail  message passed in as oMailItem 
Private Function GetReply(oMailItem As MailItem) As MailItem 
Dim conItem As Outlook.Conversation 
Dim ConTable As Outlook.Table 
Dim ConArray() As Variant 
Dim MsgItem As MailItem 
Dim lp As Long 
Dim LastVerb As Long 
Dim VerbTime As Date 
Dim Clockdrift As Long 
Dim OriginatorID As String 

Set conItem = oMailItem.GetConversation ' Let Outlook and Exchange do the hard lifting to get entire converstion for email being checked. 
OriginatorID = oMailItem.PropertyAccessor.BinaryToString(oMailItem.PropertyAccessor.GetProperty(PR_RECEIVED_BY_ENTRYID)) 

If Not conItem Is Nothing Then ' we have a conversation in which we should be able to match the reply 
    Set ConTable = conItem.GetTable 
    ConArray = ConTable.GetArray(ConTable.GetRowCount) 
    LastVerb = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTED) 
    Select Case LastVerb 
     Case EXCHIVERB_REPLYTOSENDER, EXCHIVERB_REPLYTOALL ', EXCHIVERB_FORWARD ' not interested in forwarded messages 
      VerbTime = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTION_TIME) 
      VerbTime = oMailItem.PropertyAccessor.UTCToLocalTime(VerbTime) ' convert to local time 
      ' Debug.Print "Reply to " & oMailItem.Subject & " sent on (local time): " & VerbTime 
      For lp = 0 To UBound(ConArray) 
       If ConArray(lp, 4) = "IPM.Note" Then ' it is a mailitem 
        Set MsgItem = ns.GetItemFromID(ConArray(lp, 0)) 'mail item to check against 
        If Not MsgItem.Sender Is Nothing Then 
         If OriginatorID = MsgItem.Sender.ID Then 
          Clockdrift = DateDiff("s", VerbTime, MsgItem.SentOn) 
          If Clockdrift >= 0 And Clockdrift < 300 Then ' Allow for a clock drift of up to 300 seconds. This may be overgenerous 
           Set GetReply = MsgItem 
           Exit For ' only interested in first matching  reply 
          End If 
         End If 
        End If 
       End If 
      Next 
     Case Else 
    End Select 
End If 
' as we exit function GetMsg is either Nothing or the reply we are interested in 
End Function 

Public Sub ListIt() 
Dim myOlApp As New Outlook.Application 
Dim myItem As Object ' item may not necessarily be a mailitem 
Dim myReplyItem As Outlook.MailItem 
Dim myFolder As Folder 
Dim xlRow As Long 

Set ns = myOlApp.GetNamespace("MAPI") ' Initialise Outlook access 
Set myFolder = ns.PickFolder() ' for the sake of this example we just pick a folder. 

InitSheet Sheet1 ' initialise the spreadsheet 

xlRow = 3 
For Each myItem In myFolder.Items 
    If myItem.Class = olMail Then 
     Set myReplyItem = GetReply(myItem) ' this example only deals with mailitems 
     If Not myReplyItem Is Nothing Then ' we found a reply 
      PopulateSheet Sheet1, myItem, myReplyItem, xlRow 
      xlRow = xlRow + 1 
     End If 
    End If 
    DoEvents ' cheap and nasty way to allow other things to happen 
Next 

MsgBox "Congrats! You now know your Average Response time! Kudos my friend!" 

End Sub 

Private Sub InitSheet(mySheet As Worksheet) 
With mySheet 
    .Cells.Clear 
    .Cells(1, 1).FormulaR1C1 = "Received" 
    .Cells(2, 1).FormulaR1C1 = "From" 
    .Cells(2, 2).FormulaR1C1 = "Subject" 
    .Cells(2, 3).FormulaR1C1 = "Date/Time" 
    .Cells(1, 4).FormulaR1C1 = "Replied" 
    .Cells(2, 4).FormulaR1C1 = "From" 
    .Cells(2, 5).FormulaR1C1 = "To" 
    .Cells(2, 6).FormulaR1C1 = "Subject" 
    .Cells(2, 7).FormulaR1C1 = "Date/Time" 
    .Cells(2, 8).FormulaR1C1 = "Response Time" 
    .Cells(2, 9).FormulaR1C1 = "Categories" 
End With 
End Sub 

Private Sub PopulateSheet(mySheet As Worksheet, myItem As MailItem,  myReplyItem As MailItem, xlRow As Long) 
Dim recips() As String 
Dim myRecipient As Outlook.Recipient 
Dim lp As Long 

With mySheet 
    .Cells(xlRow, 1).FormulaR1C1 = myItem.SenderEmailAddress 
    .Cells(xlRow, 2).FormulaR1C1 = myItem.Subject 
    .Cells(xlRow, 3).FormulaR1C1 = myItem.ReceivedTime 
    .Cells(xlRow, 4).FormulaR1C1 = myReplyItem.SenderEmailAddress 
    .Cells(xlRow, 9).FormulaR1C1 = myItem.Categories 
     '.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) ' I prefer to see the SMTP address 
    For lp = 0 To myReplyItem.Recipients.Count - 1 
     ReDim Preserve recips(lp) As String 
     recips(lp) = myReplyItem.Recipients(lp + 1).Address 
    Next 
    .Cells(xlRow, 5).FormulaR1C1 = Join(recips, vbCrLf) 
    .Cells(xlRow, 6).FormulaR1C1 = myReplyItem.Subject 
    .Cells(xlRow, 7).FormulaR1C1 = myReplyItem.SentOn 
    .Cells(xlRow, 8).FormulaR1C1 = "=RC[-1]-RC[-5]" 
    .Cells(xlRow, 8).NumberFormat = "[h]:mm:ss" 

End With 
End Sub 

Answer 1

尝试设置你的潜艇是专用的，而不是上市公司，即解决了它大部分的时间。