• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA for splitting cell in outlook

Elgohary11

New Member
Hello!

I have this code in outlook that pulls all the items in the inbox and creates an excel document. I want to split the last cell, the categories, so that they are in different cells not in one. Can anyone help with the code?

Thank you so much!

Here is my current code:
Sub ExportMessagesToExcel()

Dim olkMsg As Object, _

excApp As Object, _

excWkb As Object, _

excWks As Object, _

intRow As Integer, _

intVersion As Integer, _

strFilename As String

strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")

If strFilename <> "" Then

intVersion = GetOutlookVersion()

Set excApp = CreateObject("Excel.Application")

Set excWkb = excApp.Workbooks.Add()

Set excWks = excWkb.ActiveSheet

'Write Excel Column Headers

With excWks

.Cells(1, 1) = "Subject"

.Cells(1, 2) = "Received"

.Cells(1, 3) = "Sender"

.Cells(1, 4) = "Categorize"

End With

intRow = 2

'Write messages to spreadsheet

For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items

'Only export messages, not receipts or appointment requests, etc.

If olkMsg.Class = olMail Then

'Add a row for each field in the message you want to export

excWks.Cells(intRow, 1) = olkMsg.Subject

excWks.Cells(intRow, 2) = olkMsg.ReceivedTime

excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)

excWks.Cells(intRow, 4) = Split(olkMsg.Categories, ",")

excWks.Cells(intRow, 5) = Split(olkMsg.Categories, ",")

intRow = intRow + 1

End If

Next

Set olkMsg = Nothing

excWkb.SaveAs strFilename

excWkb.Close

End If

Set excWks = Nothing

Set excWkb = Nothing

Set excApp = Nothing

MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"

End Sub


Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String

Dim olkSnd As Outlook.AddressEntry, olkEnt As Object

On Error Resume Next

Select Case intOutlookVersion

Case Is < 14

If Item.SenderEmailType = "EX" Then

GetSMTPAddress = SMTP2007(Item)

Else

GetSMTPAddress = Item.SenderEmailAddress

End If

Case Else

Set olkSnd = Item.Sender

If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then

Set olkEnt = olkSnd.GetExchangeUser

GetSMTPAddress = olkEnt.PrimarySmtpAddress

Else

GetSMTPAddress = Item.SenderEmailAddress

End If

End Select

On Error GoTo 0

Set olkPrp = Nothing

Set olkSnd = Nothing

Set olkEnt = Nothing

End Function


Function GetOutlookVersion() As Integer

Dim arrVer As Variant

arrVer = Split(Outlook.Version, ".")

GetOutlookVersion = arrVer(0)

End Function


Function SMTP2007(olkMsg As Outlook.MailItem) As String

Dim olkPA As Outlook.PropertyAccessor

On Error Resume Next

Set olkPA = olkMsg.PropertyAccessor

SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")

On Error GoTo 0

Set olkPA = Nothing

End Function
 
Back
Top