J
JMay
I receive e-mails each day form our 80 stores. In the body of each e-mail
the sender provides the following data. Our Price Is Our stores price per
gallon
for Regular, Plus, Premium, Diesel, Kerosene, Off-Road, E85 and BioDiesel
(eight different ttpe fuels (which may or not apply ( the commas separate).
After Our Price comes the local compitition's prices for the same.
OUR PRICE, 1.99, 2.09, 2.19,, 1.99,,2.50
EXXON, 1.97, 2.07, 2.17, 1.99,,
TEXACO, 1.97, 2.07, 2.17,,
BP, 1.97, 2.07, 2.17, 2.05,,
WILCO, 1.85, 1.97, 2.09, 1.99,,
I am extracting this info from each e-mail (In Outlook 2003) and bringing it
into Excel 2003, but the results are inconsistent. Below is the macro I
created and it worked on my Office PC, but when I delivered it to the client,
it failed..
The macro processes 1 out of 10 without a hitch, but the others it will
import 2 or 3 of the 4 0r 5 line and stop on the 1st line after the DO
statement and provide a R/T error 5 - invalid procedure or argument... Each
line of my data ends with a Chr(13) and a Chr(10) - and no telling what else
(Chr(160).. How can I rewrite the DO statement to eliminate this problem?
Thanks for any help!!!!
Jim
Sub ReadMailToDataSheet() 'Read in Subject line and body of all e-mails
currently in Outlook Inbox Folder
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim Subj As String
Dim res As Variant
Dim dres As Date
Dim stBody As String
Dim StNum As String
Dim LineBreak As Long
Dim i As Long
Dim ctr As Long
Application.ScreenUpdating = False
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("Personal
Folders").Folders("Inbox").Folders("DailyReports")
tday1 = Date
tday1 = Format(tday1, "mm/dd/yyyy")
res = InputBox("Enter Business Reporting Date" & vbCrLf & "format must be
entered, as shown.", "Date Input", tday1, vbOKCancel)
If res = "" Then Exit Sub
If IsDate(res) Then dres = CDate(res)
Sheets("DataRecd").Activate
Range("A2:W6000").ClearContents
Range("A2:A6000").FormatConditions.Delete
ActiveSheet.Columns("P
").EntireColumn.NumberFormat = "@"
ActiveSheet.Columns("Q:Q").EntireColumn.NumberFormat = "General"
Range("A1").Select
i = 2
nxtbr = 2
For Each olMail In Fldr.Items
stBody = olMail.Body
LineBreak = 1
Do
ActiveSheet.Cells(i, 1).Value = _
Mid(stBody, LineBreak, InStr(LineBreak, stBody, Chr(10)) - LineBreak)
LineBreak = InStr(LineBreak + 1, stBody, Chr(10)) + 1
i = i + 1
Loop Until LineBreak = 0 Or LineBreak > Len(stBody)
Currlr = Range("A" & Rows.Count).End(xlUp).Row
Subj = olMail.Subject
StNum = ExtractNum(Subj)
Range("N" & nxtbr & ":N" & Currlr).Formula = "=Len(A" & nxtbr & ")"
Range("O" & nxtbr & ":O" & Currlr).Value = dres
Range("P" & nxtbr & "" & Currlr).Value = StNum
Range("Q" & nxtbr & ":Q" & Currlr).Formula = "=P" & nxtbr & "&
CHOOSE(COUNTIF($P$" & nxtbr & "" & nxtbr & ",P" & nxtbr &
"),"""",""a"",""b"",""c"",""d"",""e"",""f"",""g"",""h"",""i"",""j"")"
Range("R" & nxtbr & ":R" & Currlr).Formula = "=VLOOKUP(P" & nxtbr &
",StoreList,2,FALSE)"
Range("S" & nxtbr & ":S" & Currlr).Formula = "=IF(LEFT(A" & nxtbr &
",9)=""Our Price"",""N"",""Y"" )"
nxtbr = Currlr + 1
i = Currlr + 2
Next olMail
Range("A1").Select
ActiveSheet.Columns(1).AutoFit
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="=1", Operator:=xlOr, _
Criteria2:="=0"
With ActiveSheet.AutoFilter.Range
Set MyRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.Cells.SpecialCells(xlCellTypeVisible)
End With
MyRng.EntireRow.Delete
Selection.AutoFilter Field:=14, Criteria1:="=2", Operator:=xlOr
With ActiveSheet.AutoFilter.Range
Set MyRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.Cells.SpecialCells(xlCellTypeVisible)
End With
MyRng.EntireRow.Delete
Selection.AutoFilter
Lr = Range("A" & Rows.Count).End(xlUp).Row 'This is the Last Row of the
Imported Data
Range("$V$2:$V" & Lr).ClearContents
Range("$V$2:$V$" & Lr).Formula = "=Countif(CompetitorsOnly,DataRecd!$P2)+1"
Range("P2").Select
With Range("$P$2:$P$" & Lr)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=Countif($P$2:$P$" & Lr & ",$P2)>$V2"
.FormatConditions(1).Interior.ColorIndex = 4
End With
ActiveSheet.Columns("T:U").EntireColumn.Hidden = True
Range("A2").Select
Application.ScreenUpdating = True
Set MyRng = Nothing
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
End Sub
the sender provides the following data. Our Price Is Our stores price per
gallon
for Regular, Plus, Premium, Diesel, Kerosene, Off-Road, E85 and BioDiesel
(eight different ttpe fuels (which may or not apply ( the commas separate).
After Our Price comes the local compitition's prices for the same.
OUR PRICE, 1.99, 2.09, 2.19,, 1.99,,2.50
EXXON, 1.97, 2.07, 2.17, 1.99,,
TEXACO, 1.97, 2.07, 2.17,,
BP, 1.97, 2.07, 2.17, 2.05,,
WILCO, 1.85, 1.97, 2.09, 1.99,,
I am extracting this info from each e-mail (In Outlook 2003) and bringing it
into Excel 2003, but the results are inconsistent. Below is the macro I
created and it worked on my Office PC, but when I delivered it to the client,
it failed..
The macro processes 1 out of 10 without a hitch, but the others it will
import 2 or 3 of the 4 0r 5 line and stop on the 1st line after the DO
statement and provide a R/T error 5 - invalid procedure or argument... Each
line of my data ends with a Chr(13) and a Chr(10) - and no telling what else
(Chr(160).. How can I rewrite the DO statement to eliminate this problem?
Thanks for any help!!!!
Jim
Sub ReadMailToDataSheet() 'Read in Subject line and body of all e-mails
currently in Outlook Inbox Folder
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim Subj As String
Dim res As Variant
Dim dres As Date
Dim stBody As String
Dim StNum As String
Dim LineBreak As Long
Dim i As Long
Dim ctr As Long
Application.ScreenUpdating = False
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("Personal
Folders").Folders("Inbox").Folders("DailyReports")
tday1 = Date
tday1 = Format(tday1, "mm/dd/yyyy")
res = InputBox("Enter Business Reporting Date" & vbCrLf & "format must be
entered, as shown.", "Date Input", tday1, vbOKCancel)
If res = "" Then Exit Sub
If IsDate(res) Then dres = CDate(res)
Sheets("DataRecd").Activate
Range("A2:W6000").ClearContents
Range("A2:A6000").FormatConditions.Delete
ActiveSheet.Columns("P
").EntireColumn.NumberFormat = "@"ActiveSheet.Columns("Q:Q").EntireColumn.NumberFormat = "General"
Range("A1").Select
i = 2
nxtbr = 2
For Each olMail In Fldr.Items
stBody = olMail.Body
LineBreak = 1
Do
ActiveSheet.Cells(i, 1).Value = _
Mid(stBody, LineBreak, InStr(LineBreak, stBody, Chr(10)) - LineBreak)
LineBreak = InStr(LineBreak + 1, stBody, Chr(10)) + 1
i = i + 1
Loop Until LineBreak = 0 Or LineBreak > Len(stBody)
Currlr = Range("A" & Rows.Count).End(xlUp).Row
Subj = olMail.Subject
StNum = ExtractNum(Subj)
Range("N" & nxtbr & ":N" & Currlr).Formula = "=Len(A" & nxtbr & ")"
Range("O" & nxtbr & ":O" & Currlr).Value = dres
Range("P" & nxtbr & "
" & Currlr).Value = StNumRange("Q" & nxtbr & ":Q" & Currlr).Formula = "=P" & nxtbr & "&
CHOOSE(COUNTIF($P$" & nxtbr & "
" & nxtbr & ",P" & nxtbr &"),"""",""a"",""b"",""c"",""d"",""e"",""f"",""g"",""h"",""i"",""j"")"
Range("R" & nxtbr & ":R" & Currlr).Formula = "=VLOOKUP(P" & nxtbr &
",StoreList,2,FALSE)"
Range("S" & nxtbr & ":S" & Currlr).Formula = "=IF(LEFT(A" & nxtbr &
",9)=""Our Price"",""N"",""Y"" )"
nxtbr = Currlr + 1
i = Currlr + 2
Next olMail
Range("A1").Select
ActiveSheet.Columns(1).AutoFit
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="=1", Operator:=xlOr, _
Criteria2:="=0"
With ActiveSheet.AutoFilter.Range
Set MyRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.Cells.SpecialCells(xlCellTypeVisible)
End With
MyRng.EntireRow.Delete
Selection.AutoFilter Field:=14, Criteria1:="=2", Operator:=xlOr
With ActiveSheet.AutoFilter.Range
Set MyRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.Cells.SpecialCells(xlCellTypeVisible)
End With
MyRng.EntireRow.Delete
Selection.AutoFilter
Lr = Range("A" & Rows.Count).End(xlUp).Row 'This is the Last Row of the
Imported Data
Range("$V$2:$V" & Lr).ClearContents
Range("$V$2:$V$" & Lr).Formula = "=Countif(CompetitorsOnly,DataRecd!$P2)+1"
Range("P2").Select
With Range("$P$2:$P$" & Lr)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=Countif($P$2:$P$" & Lr & ",$P2)>$V2"
.FormatConditions(1).Interior.ColorIndex = 4
End With
ActiveSheet.Columns("T:U").EntireColumn.Hidden = True
Range("A2").Select
Application.ScreenUpdating = True
Set MyRng = Nothing
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
End Sub