Hi. This is the first real Macro that I have created. It seems to be working great except for when I try to update a user that Already exists in my spreadsheet. Basically here is how the Macro's work together(One from Excel and one from outlook). I have a rule set up in my outlook that will move emails with a certain title to one of my folders and then run a macro on that email. It goes through the email and opens one of my excel dosuments and inputs some data into. It then saves the excel file which activates the excel macro.
In the excel workbook I have two spreadsheets. On contains usernames in column A and empty cells for the other three columns that I want to update as these emails come in. The second spreadsheet contains the info from the outlook Macro. The Macro Works good except for when I try to update the three empty columns for an existing user. Both Macros are below:
Outlook Macro
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'Excel Variables
Dim XLApp As Object, XLwb As Object, XLws As Object
Dim lRow As Long
'Variable to extract text from body
Dim MyAr() As String
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'Establish an EXCEL application object
On Error Resume Next
Set XLApp = GetObject(, "Excel.Application")
'If not found then create new instance
If Err.Number <> 0 Then
Set XLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
Set XLwb = XLApp.Workbooks.Open("Changed this for confidentiality")
'Set the relevant output sheet. Change as applicable
Set XLws = XLwb.Sheets("Outlook Data")
MyAr = Split(olMail.Body, vbCrLf)
For i = LBound(MyAr) To LBound(MyAr)
Debug.Print MyAr(i)
Next i
'Write to Excel
XLws.Range("A2").Value = olMail.Subject
XLws.Range("B2").Value = MyAr(10)
XLws.Range("C2").Value = MyAr(0)
XLws.Range("D2").Value = MyAr(4)
'Close and Clean up Excel
XLwb.Save
XLwb.Close (True)
XLApp.Quit
Set XLws = Nothing
Set XLwb = Nothing
Set XLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
Excel Macro(the part that updates a current user on spreadsheet is highlighted)
Const xlUp As Long = -4162
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lRow As Long
Dim User As String
Dim DateString As Date
Dim ExtCode As Integer
Dim rngFound As Range
Dim Lookup As String
Dim RangeF As String
Dim rng As Range
Sheets("Outlook Data").Select
If Worksheets("Outlook Data").Cells(2, "B").Value <> "" Then
'format the data from sync email
Cells.Replace What:="E-Mail sent on ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Exit Code: ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="User: ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Set the Data to variables
Worksheets("Outlook Data").Select
User = Cells(2, "B").Value
DateString = Cells(2, "C").Value
ExtCode = Cells(2, "D").Value
'determine if the user already exists on the spreadsheet
Sheets("Outlook Data").Cells(6, "B").FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(R[-4]C,'Sync Date'!R[-4]C[-1]:R[104]C[-1],1,FALSE)), 0,VLOOKUP(R[-4]C,'Sync Date'!R[-4]C[-1]:R[104]C[-1],1,FALSE))"
Range("B6").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Outlook Data").Select
Lookup = Cells(6, "B")
'If user is not found adds the user and additional columns
If Lookup = "0" Then
Sheets("Sync Date").Select
lRow = Sheets("Sync Date").Range("A" & Sheets("Sync Date").Rows.Count).End(xlUp).Row + 1
Sheets("Sync Date").Range("A" & lRow).Value = User
Sheets("Sync Date").Range("C" & lRow).Value = DateString
Sheets("Sync Date").Range("D" & lRow).Value = ExtCode
'determins Whether or not to update last succesful attempt
Select Case ExtCode
Case 0: Sheets("Sync Date").Range("B" & lRow).Value = DateString
Case 10: Sheets("Sync Date").Range("B" & lRow).Value = DateString
End Select
'If the user is found it adds info to columns
Else
Sheets("Sync Date").Activate
Set rng = ActiveSheet.Cells.Find(What:=User, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
RangeF = rng.Row
Sheets("Sync Date").Range("C" & RangeF).Value = DateString
Sheets("Sync Date").Range("D" & RangeF).Value = ExtCode
'Determines whether or not to update last succesful attempt
Select Case ExtCode
Case 0: Sheets("Sync Date").Range("B" & RangeF).Value = DateString
Case 10: Sheets("Sync Date").Range("B" & RangeF).Value = DateString
End Select
End If
End If
End Sub
Let me know if you have any questions.
This is Outlook and Excel 2010 by the way.
Bookmarks