Send e-mail via specified e-mail address

Question

My macro should send the e-mails via another e-mail address.

The e-mail address has been set up and is stored in Outlook.
I can view it in the account settings.
I set this e-mail address as the default, but the e-mail is still sent via my normal e-mail address.

I have not attached the part where the mail is compiled with the information from a table.

How can I ensure this e-mail is sent from the second mail address?

Sub Mails()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table1") 
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    Dim outlookApp As Object
    Dim mailItem As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Dim i As Long
 
    Dim otherAccount As Object
    For Each acc In outlookApp.Session.Accounts
        If acc.DisplayName = example@company.com Then 
            Set otherAccount = acc
            Exit For
        End If
    Next acc
 
    If otherAccount Is Nothing Then
        Exit Sub
    End If
 
    For i = 1 To lastRow
        If IsDate(ws.Cells(i, "E").Value) Then
            Set mailItem = outlookApp.CreateItem(0)
            With mailItem
                .SendUsingAccount = otherAccount
                .To = ws.Cells(i, "F").Value
                ' .CC = ' optional
                .Subject = "Reminder" & ws.Cells(i, "A").Value
                .HTMLBody = ""

                .Send
            End With
        End If
    Next i
 
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set otherAccount = Nothing
End Sub

Set .SendUsingAccount = otherAccount did not work.

Answer 1

I use a function able to set/extract the other account. Of course, the respective account must be configured on Outlook. My example works as an automation from Excel. Otherwise, OLook should be Outlook Application :

Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
  Dim oAccount As Object
  Set GetAccountOf = Nothing
  For Each oAccount In OLook.Session.Accounts
    If oAccount = sEmailAddress Then
      Set GetAccountOf = oAccount
      Exit Function
    End If
  Next oAccount
End Function

It should be called in the next way:

Sub SendUsingDifferentAccount()
 Dim OLook As New Outlook.Application
 Dim acc As Outlook.Account
 Dim Mitem As Outlook.MailItem
 
 Set Mitem = OLook.CreateItem(0)
    
   
    Set acc = GetAccountOf("theotherAccount@xxx.com", OLook)
    If acc Is Nothing Then MsgBox "The respective account is not recognized...": Exit Sub
    If acc.DisplayName = "theotherAccount@xxx.com" Then
        With Mitem
               
            .To = "..."
            .cc = "..."
            .BCC = "..."
         
            Set .SendUsingAccount = acc
         
            .Send
        End With
    End If
End Sub

Edited:

Please, copy only the first Sub I posted and try using the next adapted code:

Sub Mails()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table1") 
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    Dim outlookApp As Object
    Dim mailItem As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Dim i As Long
 
    Dim otherAccount As Object
    Set otherAccount = GetAccountOf("example@company.com", outlookApp)
    If otherAccount Is Nothing Then MsgBox "The respective account is not recognized...": Exit Sub
 
    For i = 1 To lastRow
        If IsDate(ws.Cells(i, "E").Value) Then
            Set mailItem = outlookApp.CreateItem(0)
            With mailItem
                Set .SendUsingAccount = otherAccount
                .To = ws.Cells(i, "F").Value
                ' .CC = ' optional
                .Subject = "Reminder" & ws.Cells(i, "A").Value
                .HTMLBody = "Test"

                .Send
            End With
        End If
    Next i
 
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set otherAccount = Nothing
End Sub

Not tested, but adapted in this way it should work (I think...)