Questions

Why do I get a big X and error 400 happen sproradically with this code?

+
0 Votes
Locked

Why do I get a big X and error 400 happen sproradically with this code?

Larry Tyner
I am using the following code to extract data from an email, put it in an excel worksheet, copy to another sheet sort and save the file and a backup copy.

In my testing sometimes it will work up to 4 times successfully and I get an error. Sometimes the error happens on the first run.

It appears the error usually happens just before the sort and sometimes with the clear contents.

Any help will be greatly appreciated.

Later Note - I fixed by adding a couple of waits - the program was running in to itself.

Would appreciate some recommendation on limiting the ranges to the last item on the page.

Thanks


Option Explicit

Sub Results()

Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace

Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer

Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")

Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

For i = 1 To OLF.Items.Count

Row = i + 2 'current Excel row

sts() = Split(OLF.Items(i).Body, vbCrLf)

For iCnt = 0 To UBound(sts)

Col = iCnt + 1 'current Excel column

colPos = InStr(sts(iCnt), ":")

If colPos > 0 Then 'we have a piece of information

If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it

'Insert into worksheet

'Insert into worksheet

Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

End If

End If

Next

Next i


'Move Emails (http://www.vbaexpress.com/forum/archive/index.php/t-30550.html)

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = Outlook.Session.Folders("Personal Folders").Folders("New Contractor Registrations")
Set myItems = myInbox.Items
' Set myDestFolder = myInbox.Folders("Processed Contractor Registrations")
Set myDestFolder = Outlook.Session.Folders("Personal Folders").Folders("Processed Contractor Registrations")
Set myItem = myItems.Find("[Subject] = 'Contractor Registration Form'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend


'CopyData and Clear Results Sheet

Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("Results").Range("A3:J1040000").Copy
Worksheets("Numerical Contractor List").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues



' Sort Contractor List by ID Number

ActiveWorkbook.Worksheets("Numerical Contractor List").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Numerical Contractor List").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Numerical Contractor List").Sort
.SetRange Range("A2:J1040000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Worksheets("Results").Range("A3:J1040000").Select
Selection.ClearContents

'Save File and Backup File

' 52 = xlOpenXMLWorkbookMacroEnabled = xlsm (with macro's in 2007-2010)

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs "C:\Users\Larry\Documents\Results.xlsm", FileFormat:=52

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs "C:\Users\Larry\Documents\ResultsBackup.xlsm", FileFormat:=52

Application.DisplayAlerts = True


End Sub

Here is corrected code.
Option Explicit

Sub Results()

Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace

Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer

Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")

Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

For i = 1 To OLF.Items.Count

Row = i + 2 'current Excel row

sts() = Split(OLF.Items(i).Body, vbCrLf)

For iCnt = 0 To UBound(sts)

Col = iCnt + 1 'current Excel column

colPos = InStr(sts(iCnt), ":")

If colPos > 0 Then 'we have a piece of information

If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it

'Insert into worksheet

'Insert into worksheet

Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

End If

End If

Next

Next i


'Move Emails (http://www.vbaexpress.com/forum/archive/index.php/t-30550.html)

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = Outlook.Session.Folders("Personal Folders").Folders("New Contractor Registrations")
Set myItems = myInbox.Items
' Set myDestFolder = myInbox.Folders("Processed Contractor Registrations")
Set myDestFolder = Outlook.Session.Folders("Personal Folders").Folders("Processed Contractor Registrations")
Set myItem = myItems.Find("[Subject] = 'Contractor Registration Form'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend


'CopyData and Clear Results Sheet

Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Worksheets("Results").Range("A3:J1040000").Copy
Worksheets("Numerical Contractor List").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

Application.Wait (Now() + TimeValue("00:00:30"))

Worksheets("Results").Range("A3:J1040000").Select
Selection.ClearContents

Application.Wait (Now() + TimeValue("00:00:45"))


' Sort Contractor List by ID Number

ActiveWorkbook.Worksheets("Numerical Contractor List").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Numerical Contractor List").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Numerical Contractor List").Sort
.SetRange Range("A2:J1040000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


'Save File and Backup File

' 52 = xlOpenXMLWorkbookMacroEnabled = xlsm (with macro's in 2007-2010)

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs "C:\Users\Larry\Documents\Results.xlsm", FileFormat:=52

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs "C:\Users\Larry\Documents\ResultsBackup.xlsm", FileFormat:=52

Application.DisplayAlerts = True

Application.Wait (Now() + TimeValue("00:00:20"))

Application.Quit


End Sub