Macro para enviar correos masivos con adjuntos diferentes

En la red he encontrado, varias macros y códigos para realizar el envío masivo de archivos adjuntos a diferentes correos, sin embargo mi problema es el siguiente, mi aplicación outlook, posee dos cuentas una personal y otra corporativa y el mensaje debe salir de la segunda, no le logrado conseguir esto. Estos son los códigos que encontré en una respuesta por el usuario Dante. Amor (el cual es bueno) sin embargo no he logrado ubicarlo para hallar la solución.

Sub Enviar_Correos()
'---
' Por.Dante Amor
'---
'***Macro Para enviar correos
col = Range("H1").Column
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
dam.To = Range("B" & i).Value 'Destinatarios
dam.Cc = Range("C" & i).Value 'Con copia
dam.Bcc = Range("D" & i).Value 'Con copia oculta
dam.Subject = Range("E" & i).Value '"Asunto"
dam.Body = Range("F" & i).Value '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j).Value
If archivo <> "" Then dam.Attachments.Add archivo
Next
dam.Send 'El correo se envía en automático
'dam.Display 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
On Error Resume Next
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "G").Select
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, _
Address:="", _
SubAddress:="Hoja1!C" & t.Row, _
TextToDisplay:="Insertar archivo"
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
linea = ActiveCell.Row
'col = Range("H1").Column
col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
If col < 8 Then col = 8
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos pdf", "*.pdf*"
.Filters.Add "archivos de excel", "*.xls*"
.Filters.Add "Todos los archivos", "*.*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show Then
For Each ar In .SelectedItems
'rutaarchivo = .SelectedItems.Item(i)
Cells(linea, col) = ar
col = col + 1
Next
End If
End With
End Sub