Link to home
Create AccountLog in
Avatar of narbot
narbot

asked on

How can I update specific excel row data with Outlook VBA?

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

Open in new window

Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

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
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]+)([\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")
        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

Open in new window

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
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]+)([\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")
        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

Open in new window

Avatar of narbot
narbot

ASKER

Thanks for the reply Chris!  However, I tested the code and ran into this problem:
error.JPG
Change it to object ... that is an excel definition but object will be fine

Chris
Avatar of narbot

ASKER

Thanks again Chris.  The script executes without any errors, but my entries are generated on a new row regardless of the new parameters.  
Can you provide a example ... i.e if data is numeric rather than the assumed alpha this could be a factot

Chris
Avatar of narbot

ASKER

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!
screenshot.JPG
ASKER CERTIFIED SOLUTION
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account