Question
-
Topic
-
Why do I get a big X and error 400 happen sproradically with this code?
LockedI 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).RowWorksheets(“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 WithWorksheets(“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 ExplicitSub 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).RowWorksheets(“Results”).Range(“A3:J1040000”).Copy
Worksheets(“Numerical Contractor List”).Cells(Rows.Count, “A”).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesApplication.Wait (Now() + TimeValue(“00:00:30”))
Worksheets(“Results”).Range(“A3:J1040000”).Select
Selection.ClearContentsApplication.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