I have the following code which copies emails from an inbox, pastes them into a workbook, transposes that info to another sheet, clears the first sheet then should loop to the next email.
It works fine for 1 email but when there are 2 or more emails I get a debug error saying array out of bounds?
Any help would be greatly appreciated,
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
Many Thanks, Josh