Question

  • Creator
    Topic
  • #2210007

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

    Locked

    by 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

All Answers

Viewing 1 reply thread