Forum Discussion

celinafregoso99's avatar
celinafregoso99
Copper Contributor
Jan 05, 2021

Outlook export multiple emails in Excel workbook but different excel worksheets

I'm new using vba, I want to export from outlook emails selected into a workbook path, and each email (subject, body,etc.) should be store in different worksheet and I'm trying to edit this macro because its almost what I needhttps://exonlinecalculator.com/ especialy the part of olFormatHTML and WordEditor, because of split

The idea is
1.-select multiple emails in Outlook
2.-open file path
3.-for each email selected in Outlook will be stored in a single worksheet from file opened

I'm getting issue with the macro in this 3rth part
A).- from selected items the macro do loop and just take the first email selected
B).- the emails store in different workbooks, should be stored in the same workbook that I opened

here is the code

Public Sub SplitEmail()

Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection

Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection

For x = 1 To myOlSel.Count

'----------------------------------------------
Set itm = GetCurrentItem() 'A)I think the issuefrom selecting 1 item is located here

'|||||||||||||||||||||||||||||||||||||||||

sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"

If Not itm Is Nothing Then

Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If

Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text

'||||||||||||||||||||||||||||||||||||||||||||||

Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile) 'B) tried to move it to the beginning and macro doesn't work

'||||||||||||||||||||||||||||||||||||||||||||||

For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i) 'B)emails in diferrent sheet but no same workbook

Next i


'------------------------------------------------------
Next x

End Sub


Function GetCurrentItem() As Object

Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next

Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing

End Function
this issue is B: The code above, when macro do loop "x" increase, the email store in different sheets but in different workbooks, should be in the same workbook

1 Reply

  • celinafregoso99's avatar
    celinafregoso99
    Copper Contributor

    HI beautiful people, if anyone facing same problem, you can try this solution i got from an expert.

     

    I made an update to this macro, tell me https://yesornogenerator.com/ if its helpful
    as macro do loop in For x it open the file x times,
    and then close it and open again instead of working on the first workbook opened
    but the macro leaves open instances
    here is the current code

    Public Sub SplitEmail()


    Dim rpl As Outlook.MailItem
    Dim itm As Object
    Dim sPath As String, sFile As String
    Dim objDoc As Word.Document
    Dim txt As String
    Dim xlApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim i As Long
    Dim x As Long
    '----------------------------
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection

    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection

    For x = 1 To myOlSel.Count

    '----------------------------------------------

    Dim objApp As Outlook.Application
    Dim GetCurrentItem As Object
    Set objApp = Application
    On Error Resume Next

    Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
    Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(x)
    Case "Inspector"
    Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select

    GetCurrentItem.UnRead = False
    Set objApp = Nothing

    '-----------------------------------------------
    Set itm = GetCurrentItem


    sPath = "C:\Users\Ray\"
    sFile = sPath & "Macro.xlsm"


    If Not itm Is Nothing Then

    'de lo contrario, se crea un Reply del correo en formato HTML
    Set rpl = itm.Reply
    rpl.BodyFormat = olFormatHTML
    'rpl.Display
    End If


    Set objDoc = rpl.GetInspector.WordEditor
    txt = objDoc.Content.Text

    '||||||||||||||||||||||||||||||||||||||||||||||

    Set xlApp = CreateObject("Excel.application")
    xlApp.Visible = True

    Set wb = xlApp.Workbooks.Open(sFile)
    xlApp.Windows("Macro.xlsm").Activate
    'Set wb = ActiveWorkbook
    '||||||||||||||||||||||||||||||||||||||||||||||

     


    For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
    wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i)
    Next i

    xlApp.Windows("Macro.xlsm").Close SaveChanges:=True
    xlApp.Workbook.Close SaveChanges:=False
    '------------------------------------------------------

     

    Next x
    '------------------------------------------------------


    'the instances should closed but not working, instances are empty

    For Each wb In xlApp
    wb.Close SaveChanges:=False
    Next


    End Sub

     

Resources