djnashvill
04-19-2011, 05:35 PM
I have VBA code in Outlook that takes row data from an Excel spreadsheet and adds contacts until it finds an empty row. The problem I have is the E-mail parsing program I have adding entries to the Excel sheet adds subsequent rows below the last row written even if I manually delete the rows. For instance if the last time the e-mail parsing program ran it ended on row 499 the next time I run it the new row will be created at row 500 even if I delete the previous 499 before hand which I do after the code has ran.
I need a way to modify the code I am using to get it to find the first row with data in Column A and then import from there until it finds the next blank row.
The code is below and I am using it in Outlook 2007 and Excel 2007
Public Sub cmdImportContacts_Click()
Const olContactItem = 2
Set objOutlook = CreateObject("Outlook.Application")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\Doug\Documents\trumpispreadsheet.xls")
x = 1
Do Until objExcel.Cells(x, 1).Value = ""
Set objContact = objOutlook.CreateItem(olContactItem)
objContact.FullName = objExcel.Cells(x, 1).Value
objContact.Email1Address = objExcel.Cells(x, 2).Value
objContact.Birthday = objExcel.Cells(x, 5).Value
objContact.Categories = objExcel.Cells(x, 4).Value
objContact.Save
x = x + 1
Loop
MsgBox "Done"
objExcel.Quit
End Sub
I need a way to modify the code I am using to get it to find the first row with data in Column A and then import from there until it finds the next blank row.
The code is below and I am using it in Outlook 2007 and Excel 2007
Public Sub cmdImportContacts_Click()
Const olContactItem = 2
Set objOutlook = CreateObject("Outlook.Application")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\Doug\Documents\trumpispreadsheet.xls")
x = 1
Do Until objExcel.Cells(x, 1).Value = ""
Set objContact = objOutlook.CreateItem(olContactItem)
objContact.FullName = objExcel.Cells(x, 1).Value
objContact.Email1Address = objExcel.Cells(x, 2).Value
objContact.Birthday = objExcel.Cells(x, 5).Value
objContact.Categories = objExcel.Cells(x, 4).Value
objContact.Save
x = x + 1
Loop
MsgBox "Done"
objExcel.Quit
End Sub