Clicky

I cannibalized the attached code from other outlook functions.  Currently, I am able to send an e-mail and use Outlook rules to automatically update an excel file by adding rows with the provided data.  Instead of creating a new row for each update though, how can I modify my code to update rows based on specific criteria in column A?  That is, update the row only if SenderName matches the staff column?

Example... John Smith sends an email to update his status.  Only the data in the row where the column A value matches his SenderName is updated to display his current status.
 Sub STATUSREPORT(mai As MailItem) Dim staff As String Dim status As String Dim dateRecd As String Dim ln As Variant Dim strTemp As String Dim xlApp As Object Dim rw As Long Const xlup As Integer = -4162      dateRecd = Format(mai.ReceivedTime, "hhmm, mmm-dd-yyyy")     staff = mai.SenderName '    status = getDatabyRegEx(mai.body, "(status[ \xA0]+?:[ \xA0]+)([\w\s]{1,}[\r\n])")     For Each ln In Split(Replace(mai.Body, Chr(160), " "), vbCrLf)         If LCase(ln) Like "status*" Then             status = Trim(Split(ln, ":")(1))         End If     Next     Set xlApp = CreateObject("excel.application")     With xlApp.workbooks.Open("C:\status_report.xls")         rw = .sheets(1).Range("A" & .sheets(1).Rows.Count).End(xlup).Row + 1         .sheets(1).Range("A" & rw) = staff         .sheets(1).Range("B" & rw) = status         .sheets(1).Range("C" & rw) = dateRecd         .Close True     End With     xlApp.Quit End Sub                              
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 

Select allOpen in new window

asked 01/03/2011 11:51

narbot's gravatar image

narbot ♦♦


8 Answers:
Try the following which does a search on column 1 for the staff value and if found updates the two adjacent cells.  If not it should contiue as before to add the data row.

Chris
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
Sub STATUSREPORT(mai As MailItem)
Dim staff As String
Dim status As String
Dim dateRecd As String
Dim ln As Variant
Dim strTemp As String
Dim xlApp As Object
Dim rw As Long
Dim rng As Range
Const xlup As Integer = -4162

    dateRecd = Format(mai.ReceivedTime, "hhmm, mmm-dd-yyyy")
    staff = mai.SenderName
'    status = getDatabyRegEx(mai.body, "(status[ xA0]+?:[ xA0]+)([ws]{1,}[
])")
    For Each ln In Split(Replace(mai.Body, Chr(160), " "), vbCrLf)
        If LCase(ln) Like "status*" Then
            status = Trim(Split(ln, ":")(1))
        End If
    Next
    Set xlApp = CreateObject("excel.application")
    With xlApp.workbooks.Open("C:status_report.xls")
        On Error Resume Next
        Set rng = .Sheets(1).Columns(1).Find(What:="staff", LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
        On Error GoTo 0
        If rng Is Nothing Then
            rw = .sheets(1).Range("A" & .sheets(1).Rows.Count).End(xlup).Row + 1
            .sheets(1).Range("A" & rw) = staff
            .sheets(1).Range("B" & rw) = status
            .sheets(1).Range("C" & rw) = dateRecd
        else
            rng.Offset(0, 1) = Status
            rng.Offset(0, 2) = dateRecd
        end if
        .Close True
    End With
    xlApp.Quit
End Sub
link

answered

chris_bottomley's gravatar image

chris_bottomley

I tested with a variant ... since I didn't have everything from your own setup and missed a correction for yours above so modified below.

Chris
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
Sub STATUSREPORT(mai As MailItem)
Dim staff As String
Dim status As String
Dim dateRecd As String
Dim ln As Variant
Dim strTemp As String
Dim xlApp As Object
Dim rw As Long
Dim rng As Range
Const xlup As Integer = -4162

    dateRecd = Format(mai.ReceivedTime, "hhmm, mmm-dd-yyyy")
    staff = mai.SenderName
'    status = getDatabyRegEx(mai.body, "(status[ xA0]+?:[ xA0]+)([ws]{1,}[
])")
    For Each ln In Split(Replace(mai.Body, Chr(160), " "), vbCrLf)
        If LCase(ln) Like "status*" Then
            status = Trim(Split(ln, ":")(1))
        End If
    Next
    Set xlApp = CreateObject("excel.application")
    With xlApp.workbooks.Open("C:status_report.xls")
        On Error Resume Next
        Set rng = .Sheets(1).Columns(1).Find(What:=staff, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
        On Error GoTo 0
        If rng Is Nothing Then
            rw = .sheets(1).Range("A" & .sheets(1).Rows.Count).End(xlup).Row + 1
            .sheets(1).Range("A" & rw) = staff
            .sheets(1).Range("B" & rw) = status
            .sheets(1).Range("C" & rw) = dateRecd
        else
            rng.Offset(0, 1) = Status
            rng.Offset(0, 2) = dateRecd
        end if
        .Close True
    End With
    xlApp.Quit
End Sub
link

answered 2011-01-04 at 20:56:43

chris_bottomley's gravatar image

chris_bottomley

Thanks for the reply Chris!  However, I tested the code and ran into this problem:
link

answered 2011-01-04 at 20:58:28

narbot's gravatar image

narbot

Change it to object ... that is an excel definition but object will be fine

Chris
link

answered 2011-01-05 at 06:53:42

chris_bottomley's gravatar image

chris_bottomley

Thanks again Chris.  The script executes without any errors, but my entries are generated on a new row regardless of the new parameters.  
link

answered 2011-01-05 at 07:00:57

narbot's gravatar image

narbot

Can you provide a example ... i.e if data is numeric rather than the assumed alpha this could be a factot

Chris
link

answered 2011-01-05 at 08:53:27

chris_bottomley's gravatar image

chris_bottomley

Sure... an example is attached.  What I want is for sender John Smith's status to update on row 1 rather than generate a new row.  I'm sure this is very obnoxious, but I appreciate your help!
link

answered 2011-01-05 at 09:34:13

narbot's gravatar image

narbot

Some of the constants were missed ... but I would have expected errors.  I have created a test mail and run it in outlook and all is well.

Chris
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
Sub STATUSREPORT(mai As MailItem)
Dim staff As String
Dim status As String
Dim dateRecd As String
Dim ln As Variant
Dim strTemp As String
Dim xlApp As Object
Dim rw As Long
Dim rng As Object
Const xlup As Integer = -4162
Const xlvalues As Integer = -4163
Const xlwhole As Integer = 1
Const xlByRows As Integer = 1

    dateRecd = Format(mai.ReceivedTime, "hhmm, mmm-dd-yyyy")
    staff = mai.SenderName
'    status = getDatabyRegEx(mai.body, "(status[ xA0]+?:[ xA0]+)([ws]{1,}[
])")
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
        If LCase(ln) Like "status*" Then
            status = Trim(Split(ln, ":")(1))
        End If
    Next
    Set xlApp = CreateObject("excel.application")
    With xlApp.workbooks.Open("C:status_report.xls")
        On Error Resume Next
        Set rng = .sheets(1).Columns(1).Find(What:=staff, LookIn:=xlvalues, _
        LookAt:=xlwhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
        On Error GoTo 0
        If rng Is Nothing Then
            rw = .sheets(1).Range("A" & .sheets(1).Rows.count).End(xlup).Row + 1
            .sheets(1).Range("A" & rw) = staff
            .sheets(1).Range("B" & rw) = status
            .sheets(1).Range("C" & rw) = dateRecd
        Else
            rng.Offset(0, 1) = status
            rng.Offset(0, 2) = dateRecd
        End If
        .Close True
    End With
    xlApp.Quit
End Sub
link

answered 2011-01-05 at 13:32:20

chris_bottomley's gravatar image

chris_bottomley

Your answer
[hide preview]

Follow this question

By Email:

Once you sign in you will be able to subscribe for any updates here

By RSS:

Answers

Answers and Comments

Tags:

×19
×21
×83

Asked: 01/03/2011 11:51

Seen: 234 times

Last updated: 12/14/2011 03:32