数组越界，错误

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

它工作正常的1电子邮件，但有2个或更多的电子邮件时，我得到一个debugging错误，说数组越界？

任何帮助将不胜感激，

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 

非常感谢，乔希