Mas onde vc alterou que passou a dar erro?

Refiz o codigo, com a ajuda de outras macros que aqui tenho, fiz os testes e ok, porem a conta que quero que o email seja enviado, nao esta sendo a correta, pois esta enviando pela conta padrao do Outlook, quero que a conta de envio seja a que estiver na celula " AI28 ".

segue o codigo e a planilha

Grato se puder mais esta vez ajudar o amigo aqui.

Andre

Sub A6_Leader()
' Macro Usada para Solicitacao de Frete ou Envio de Pedido


Dim nome
nome = Range("AH31")


Dim sPlanAEnviar As String
Dim OlMensagem As Outlook.MailItem
Dim OlApp As Outlook.Application
Dim contaEmail As String
Dim idEmail As Integer


Dim oOutlook As Object
Dim oEmail As Object
Dim wbAtual As Workbook
Dim sNomeArquivo As String
Dim sLocalTemp As String
Dim resultado  As VbMsgBoxResult
Dim Status      As String
Status = Range("AI23").Value ' Da Planilha Pedido Leader (nome)

Application.ScreenUpdating = False
Set oOutlook = CreateObject("Outlook.Application")
Set oEmail = oOutlook.CreateItem(0)
sLocalTemp = "C:UsersAndreDesktop"

' Copia a planilha ativa e salva em local temporário
ActiveSheet.Copy
Set wbAtual = ActiveWorkbook

' Aqui você define qual planilha deve ser gravada
sNomeArquivo = wbAtual.Worksheets(nome).Name

On Error Resume Next
Kill sLocalTemp & sNomeArquivo
On Error GoTo 0
wbAtual.SaveAs Filename:=sLocalTemp & sNomeArquivo
'---------------------------------------------------------------

contaEmail = ThisWorkbook.Sheets(nome).Range("AI28").Value

    Set OlApp = CreateObject("Outlook.Application")
    Set OlMensagem = OlApp.CreateItem(0)


   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For w = 1 To OlApp.Session.Accounts.Count
                            
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
    Next


    With OlMensagem

       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)

  Set OlApp = Nothing



With oEmail
    .To = "amigolojista@gmail.com"
    
'-------------------------------------------------------------------------------
'Aqui será escolhido se o Envio é uma Solicitação de Frete ou Pedido !
    
If Status = "CONSULTAR" Then
    
    .Subject = "Consulta " & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue um possível pedido para ser consultado a análise de crédito. Favor conferir se batem os valores apresentados, formas de pagamento. Favor tambem na parte inferior do pedido analisar as Observações. Aguardo apuração para informar ao cliente e assim poder liberar este pedido"

Else
    .Subject = "Pedido Aprovado" & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue o Pedido Aprovado. Favor se atente a parte inferior do pedido quanto as Observações. Aguardo a confirmação deste Pedido e informações previstas da entrega"
    
End If
    
    .Attachments.Add wbAtual.FullName
    
    
'---------------------------------------------------------------------------------
 
    .ReadReceiptRequested = True ' confirmação de leitura

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

resultado = MsgBox("Deseja ver o Envio e Adicionar um anexo( SIM ) ou ( NÃO ) ?", vbYesNo, "Tomando uma Decisão")
        
If resultado = vbYes Then
    .Display
 Else
    .Send
End If


wbAtual.ChangeFileAccess Mode:=xlReadOnly
Kill wbAtual.FullName
wbAtual.Close SaveChanges:=False

Set oEmail = Nothing
Set oOutlook = Nothing


'-------------------------------------------
'-------------------------------------------
End With
End With

GoTo Fim
Fim:


End Sub

Quebrei aqui a cabeça e resolvi

Grato a todos, mas desta vez consegui sozinho.

Se faltar algo, com certeza corro aqui.

Sub A6_Leader()

Dim OlMensagem As Outlook.MailItem
Dim OlApp As Outlook.Application
Dim contaEmail As String
Dim idEmail As Integer
Dim oOutlook As Object
'                 Dim oEmail As Object
Dim wbAtual As Workbook
Dim sNomeArquivo As String
Dim sLocalTemp As String
Dim resultado  As VbMsgBoxResult
Dim Status      As String
Status = Range("AI23").Value ' Da Planilha Pedido Leader (nome)
Dim nome
nome = Range("AH31")

Application.ScreenUpdating = False
Set oOutlook = CreateObject("Outlook.Application")
'  Set oEmail = oOutlook.CreateItem(0)
Set oMensagem = oOutlook.CreateItem(0)
sLocalTemp = "C:UsersAndreDesktop"

' Copia a planilha ativa e salva em local temporário
ActiveSheet.Copy
Set wbAtual = ActiveWorkbook

' Aqui você define qual planilha deve ser gravada
sNomeArquivo = wbAtual.Worksheets(nome).Name

On Error Resume Next
Kill sLocalTemp & sNomeArquivo
On Error GoTo 0
wbAtual.SaveAs Filename:=sLocalTemp & sNomeArquivo
'---------------------------------------------------------------

contaEmail = ThisWorkbook.Sheets(nome).Range("AI28").Value

    'Create the Outlook application and the empty email.
    Set OlApp = CreateObject("Outlook.Application")
  Set OlMensagem = OlApp.CreateItem(0)

   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For w = 1 To OlApp.Session.Accounts.Count


  If OlApp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
           
    idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
           Else
            End If

    Next

'Using the email, add multiple recipients, using a list of addresses in column C.
  With OlMensagem
  
    .Display
    .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
    .To = "amigolojista@gmail.com"
    
'-------------------------------------------------------------------------------
'Aqui será escolhido se o Envio é uma Solicitação de Frete ou Pedido !
    
If Status = "CONSULTAR" Then
    
    .Subject = "Consulta " & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue um possível pedido para ser consultado a análise de crédito. Favor conferir se batem os valores apresentados, formas de pagamento. Favor tambem na parte inferior do pedido analisar as Observações. Aguardo apuração para informar ao cliente e assim poder liberar este pedido"

Else
    .Subject = "Pedido Aprovado" & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue o Pedido Aprovado. Favor se atente a parte inferior do pedido quanto as Observações. Aguardo a confirmação deste Pedido e informações previstas da entrega"
    
End If
    
    .Attachments.Add wbAtual.FullName
        
'---------------------------------------------------------------------------------
 
    .ReadReceiptRequested = True ' confirmação de leitura

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

resultado = MsgBox("Deseja ver o Envio e Adicionar um anexo( SIM ) ou ( NÃO ) ?", vbYesNo, "Tomando uma Decisão")
        
If resultado = vbYes Then
    .Display
 Else
    .Send
End If

wbAtual.ChangeFileAccess Mode:=xlReadOnly
Kill wbAtual.FullName
wbAtual.Close SaveChanges:=False


Set oOutlook = Nothing

End With


End Sub