Vba 数组超出范围，错误

我有下面的代码，它从收件箱复制电子邮件，粘贴到工作簿中，将信息转换到另一个工作表，清除第一个工作表，然后循环到下一个电子邮件

它适用于1封电子邮件，但当有2封或更多电子邮件时，我会收到一个调试错误，说数组超出范围

任何帮助都将不胜感激

Sub EmailText()
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Set ObjOutlook = GetObject(, "Outlook.Application")
Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
For i = 1 To MyNamespace.GetDefaultFolder(6).Folders("TEST").Items.Count
    abody = Split(MyNamespace.GetDefaultFolder(6).Folders("TEST").Items(i).Body, Chr(13) & Chr(10))
    For j = 0 To UBound(abody)
        Sheet1.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
    Next
    MyNamespace.GetDefaultFolder(6).Folders("TEST").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("TEST2")
    Sheets("Sheet2").Select
        Dim NextRow As Range
            With Sheets("Sheet2")
                Set NextRow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
            End With
    Sheets("Sheet1").Select
    Range("E2:E7").Select
    Selection.Copy
    Sheets("Sheet2").Select
    NextRow.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Sheets("Sheet1").Select
    Range("A2:A20").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("B8").Select
Next
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
End Sub

非常感谢,，

---

Josh

我猜当您将项目

MyNamespace.GetDefaultFolder（6）.文件夹（“测试”）.Items（I）.将MyNamespace.GetDefaultFolder（6）.文件夹（“TEST2”）

移动到另一个文件夹时，项目计数会发生变化。尝试对i=MyNamespace.GetDefaultFolder（6.Folders（“TEST”）.Items.Count使用反向循环：

，直到第1步-1

非常感谢！真是太棒了！！两个侧面观察：（i）我将使用

Long

而不是

Integer

，因为后者在32767项后给出了一个错误。（ii）您不需要

将对象设置为
无
，因为此时它们会自动终止。（iii）避免使用
select
s:Great feedback@loannis是一种很好的做法。我将看看您建议的线程，并牢记这一点。谢谢