Hi,

I've got some code in excel which pulls information from selected emails in outlook (I highlight the emails I want the code to look at, then run the code).

It then pulls certain info (Sender, Subject, body text) from each selected email and logs it in excel.

This is all working fine, but I now need to assign each email a unique ID - I've adapted the code to do this, and it's working fine except that I can't get it to actually amend the email subject to include the ID. It's strange, as if I select each email individually, it works, and adds the ID to the subject - it only doesn't work if I have a batch of emails selected.

Can anyone advise as to why this is happening?

Sub CopyFromOutlook()
    Dim olApp As New Outlook.Application
    Dim olExp As Outlook.Explorer
    Dim olSel As Outlook.Selection
    Dim myArray(8) As String
    Dim subjs As Variant
    Dim Line As Long, myBody As String
    Dim mySubj As String
    Dim mySender As String
    Dim Tabl, str As String
    Dim idnum As String
    Dim i As Integer, x As Integer, n As Integer, j As Integer

idnum = Format(Worksheets("Sheet1").Cells(1, 1).Value, "00000000")

     
    On Error Resume Next
     ' Getting the messages selection
    Set olApp = Outlook.Application
    Set olExp = olApp.ActiveExplorer
    Set olSel = olExp.Selection
     ' Checking if there is at least one message selected
    If olSel.Count < 1 Then
         MsgBox "No message selected", vbExclamation, "Error"
        Exit Sub
    End If
    With Sheets("Sheet2")
         ' Retrieving the first avaible row to put message in
        Line = .Range("A65000").End(xlUp).Row + 1
         '   looping through message
        For x = 1 To olSel.Count
            DoEvents
            
            mySender = Replace(olSel.Item(x).SenderName, Chr(13), "")
            
            mySubj = Replace(olSel.Item(x).Subject, Chr(13), "")
                      
            myBody = Replace(olSel.Item(x).body, Chr(13), "")
         
            
            'splitting the subject
            
            amendsubj = olSel.Item(x).Subject & " " & idnum
            olSel.Item(x).Subject = amendsubj
            
            
                .Cells(Line, 2) = mySubj
                .Cells(Line, 1) = mySender
                .Cells(Line, 3) = myBody
                .Cells(Line, 4) = idnum
            'Next i
          
           idnum = Format(idnum + 1, "00000000")
            
            Line = Line + 1
             ' Next message
        Next x
    End With
    Worksheets("Sheet1").Cells(1, 1).Value = idnum

End Sub