Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
rotina envia corpo ...
 
Notifications
Clear all

rotina envia corpo email duplicado

 
2024 - VBA & Macros
Post Recente por fazerbem 8 anos atrás
2 Posts
1 Usuários
0 Reactions
495 Visualizações
RSS
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

Sei que a Macro em anexo está baguncada, mas esta funcionando rsrsr

A unica coisa errada é quando preciso acionar uma das rotinas abaixo, dai o primeiro Email vai normal o corpo, mas o segundo o corpo se duplica, o terceiro o corpo se triplica e assim vai. Nao sei o que esta errado,

If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 1 Then

Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
GoTo Aviso2

Else
End If

If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 2 Then

Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"

GoTo Aviso2

Else
End If

If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 3 Then

Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
GoTo Aviso2

Else
End If

If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 1 Then

Mensagem = Mensagem & Sheets("Config").Range("V1").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("V3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("V7").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("V11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("V15").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("V19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
GoTo Aviso2

Else
End If

If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 2 Then

Mensagem = Mensagem & Sheets("Config").Range("X1").Value & Chr(10) & Chr(10)

Mensagem = Mensagem & Sheets("Config").Range("X3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("X7").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("X11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("X15").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("X19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
GoTo Aviso2

Else
End If

If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 3 Then

Mensagem = Mensagem & Sheets("Config").Range("Z1").Value & Chr(10) & Chr(10)

Mensagem = Mensagem & Sheets("Config").Range("Z3").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("Z7").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("Z11").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("Z15").Value & Chr(10)
Mensagem = Mensagem & Sheets("Config").Range("Z19").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
GoTo Aviso2

Else
End If

Porem se as rotinas acimas nao forem verdadeiras, entra em ação a rotina abaixo, dai todos os emails vao normais. Talvez fosse o caso de no final da rotina e iniciando-se a proxima, tivesse uma forms de Limpar o cache da Mensagem DIM, mas nao sei como fazer.

If Range("B12").Value = 1 Then

Mensagem = " Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G2").Value & Chr(10) ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G5").Value & Chr(10) ' " Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G8").Value & Chr(10)
Mensagem = Mensagem & Range("G11").Value & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"

Else

Mensagem = " Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G19").Value & Chr(10) ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G22").Value & Chr(10) ' " Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G23").Value & Chr(10)
Mensagem = Mensagem & Range("G24").Value & Chr(10)
Mensagem = Mensagem & Range("G25").Value & Chr(10)
Mensagem = Mensagem & Range("G26").Value & Chr(10)
Mensagem = Mensagem & Range("G28").Value & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G31").Value & Chr(10)
Mensagem = Mensagem & Range("G32").Value & Chr(10)
Mensagem = Mensagem & Range("G33").Value & Chr(10)
Mensagem = Mensagem & "www.leadernutrition.com.br"

End If

Sub A1_Envio_Individual()
    '======================================
    ' Preparando o E-mail para ser enviado
    '======================================
 
  Application.ScreenUpdating = 0 'Deixa a macro mais rápida (Desliga a tela de atualização)
 
If Range("C15").Value = 6 Then
GoTo Terminar
Else
End If
 
 Dim Revenda As String
 Revenda = Range("D25")  'Aqui aparece o Nome da Revenda a ser ativada ex Aba Mundo Verde
 
' Loop Avisos Importantes
If Range("C2").Value = 1 Then

GoTo Avisos
Else
End If
 
 
If Range("E15").Value = 9 Then

     Sheets(Revenda).Visible = True
     Sheets("EN2").Visible = True
     Sheets(Revenda).Select


GoTo Diversas_Lojas
GoTo Diversas
Diversas:
Else: End If
 
If Range("E15").Value = 9 Then
GoTo A
Else: End If

If Sheets("CONFIG").Range("E18").Value = 2 Then  ' (D20)= Ativar Individual
GoTo Terminar
Else
End If
 
 GoTo Volte
Volte:
  
' Dim Revenda As String
' Revenda = Range("D25")  'Aqui aparece o Nome da Revenda a ser ativada ex Aba Mundo Verde
 
 If Range("E15").Value = 10 Then 'Seleciona a Revenda
 GoTo Terminar
 Else
      End If

GoTo Avisos
Avisos:

 If Range("D25").Value > 0 Then
     Sheets(Revenda).Visible = True  'ATIVE A REVENDA
 '    Sheets("EN").Visible = True
     
GoTo A
A:

     Sheets(Revenda).Select
  
  Else
       End If
   
 If Range("Q4").Value = "" Or Range("K4").Value = "4" Or Range("S7").Value = "" Or Range("K4").Value = "" Then
 MsgBox ("Fabricante ou Conta de E-mail ou Anexo nao informado !!")
 
 GoTo Terminar
 
 Else
 End If
    
If Range("A1").Value = "Enviar Convites" Then
    
GoTo EN2
Else: End If
    
GoTo Diversas_Lojas
Diversas_Lojas:
 
    Dim OlApp As Outlook.Application
    Dim OlMensagem As Outlook.MailItem
    Dim Leitura     As String
    Dim contaEmail As String
    Dim Loja        As String
    Dim Estado    As String
    Dim Pasta As String
    Dim Arquivo As String
    Dim i As Long
    Dim UltimaLinha As Long
    Dim Mensagem As String
    Dim Assunto     As String

    Assunto = Range("L1")
    Estado = Range("H10")
    Loja = Range("A1")
    
    Leitura = Sheets(Loja).Range("I7")

  Sheets("Envios Individuais").Visible = True
' Sheets("Config").Select
' GoTo Diversas
 '--------------------------------------------------------------

GoTo EN2
EN2:

If Range("A1").Value = "Enviar Convites" Then

Sheets("EN2").Select

If Sheets("CONFIG").Range("F29").Value = 1 Then
    Range("A2:A500").Select
    Else
If Sheets("CONFIG").Range("F29").Value = 2 Then
    Range("C2:C500").Select
    Else
If Sheets("CONFIG").Range("F29").Value = 3 Then
    Range("E2:E500").Select
    Else

    End If
    End If
    End If

    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Sheets("Enviar Convites").Select

GoTo EN2_SEGUE

Else
End If

If Range("A1").Value = "DVitaminas" Or Range("A1").Value = "Academias" Or Range("A1").Value = "SNC" Or Range("A1").Value = "Rio de Janeiro" Or Range("A1").Value = "Farmacias" Then

If Sheets("CONFIG").Range("A1").Value = "TESTE DE ENVIO" Then

Sheets("Envios Individuais").Select
Range("C3").Value = "amigolojista@gmail.com"
GoTo Segue

Else
End If

    Range("C2:C100").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
               
GoTo Segue

Else

 Sheets(Estado).Visible = True
 Sheets(Estado).Select
    Range("C1:C100").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Sheets(Loja).Select
        
If Range("H10").Value = "RJ" Or Range("H10").Value = "SP" Then

Sheets(Estado).Select
    Range("G1:G100").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("C103").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Else
End If
        
 Sheets(Estado).Visible = False
       
Sheets("Envios Individuais").Select
Range("A5").Select

End If


GoTo Segue
Segue:

GoTo EN2_SEGUE

 Sheets(Loja).Select
 
EN2_SEGUE:
 Sheets(Loja).Select
    Range("F1").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("Q1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
  
 Sheets(Loja).Select
    Range("Q6").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
 Sheets(Loja).Select
    Range("I6").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("A23").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
 Sheets(Loja).Select
    Range("K4").Select
    Selection.Copy
    Sheets("Envios Individuais").Select
    Range("B12").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
' Preste atencao aqui
      contaEmail = ThisWorkbook.Sheets("Envios Individuais").Range("A5").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
       '  For w = 1 To Correio.Session.Accounts.Count
    

    
        If OlApp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
        
      If Sheets("CONFIG").Range("D24").Value = 2 Then 'Se Envio de todos UF
        
            If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                            
  Else
  
  GoTo Fim
  
  
  
  End If
  End If
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
  
                    
       
        End If
    Next
       
       UltimaLinha = Sheets("Envios Individuais").Cells(Cells.Rows.Count, 3).End(xlUp).Row
    If UltimaLinha < 3 Then UltimaLinha = 3
           
    'Laço para pegar cada um dos destinatários da coluna B, começando na linha 3
    For i = 3 To UltimaLinha
    
  ' Create the Outlook application and the empty email.
    Set OlApp = CreateObject("Outlook.Application")
    Set OlMensagem = OlApp.CreateItem(0)
    
  'Using the email, add multiple recipients, using a list of addresses in column C.
     With OlMensagem
     
         'Campo Assunto
        .Subject = Sheets("Envios Individuais").Range("E1").Value & Assunto '"Bonus Generator"
          
        'Cria a mensagem que será enviada
        
        
 If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 1 Then
 
        Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

        Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
 GoTo Aviso2
 
 Else
 End If
 
 If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 2 Then
 
        Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

        Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"

 GoTo Aviso2
 
 Else
 End If
        
 If Sheets("Config").Range("C2").Value = 1 And Sheets("Config").Range("C24").Value = 3 Then
 
        Mensagem = Mensagem & Sheets("Config").Range("AB1").Value & Chr(10) & Chr(10)

        Mensagem = Mensagem & Sheets("Config").Range("AB3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB5").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("AB19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
 GoTo Aviso2
 
 Else
 End If
 
  If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 1 Then
 
 
        Mensagem = Mensagem & Sheets("Config").Range("V1").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("V3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("V7").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("V11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("V15").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("V19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
 GoTo Aviso2
 
 Else
 End If
 
   If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 2 Then
 
        Mensagem = Mensagem & Sheets("Config").Range("X1").Value & Chr(10) & Chr(10)

        Mensagem = Mensagem & Sheets("Config").Range("X3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("X7").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("X11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("X15").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("X19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
 GoTo Aviso2
 
 Else
 End If
 
   If Sheets("Config").Range("C3").Value = 2 And Sheets("Config").Range("C24").Value = 3 Then
 
        Mensagem = Mensagem & Sheets("Config").Range("Z1").Value & Chr(10) & Chr(10)

        Mensagem = Mensagem & Sheets("Config").Range("Z3").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("Z7").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("Z11").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("Z15").Value & Chr(10)
        Mensagem = Mensagem & Sheets("Config").Range("Z19").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
 GoTo Aviso2
 
 Else
 End If
        
        
 If Range("B12").Value = 1 Then
               
        Mensagem = "        Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G2").Value & Chr(10)  ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G5").Value & Chr(10)   ' "          Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G8").Value & Chr(10)
        Mensagem = Mensagem & Range("G11").Value & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G14").Value & Chr(10)
        Mensagem = Mensagem & Range("G15").Value & Chr(10)
        Mensagem = Mensagem & Range("G16").Value & Chr(10)
        Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"
          
Else

        Mensagem = "        Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G19").Value & Chr(10)  ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G22").Value & Chr(10)   ' "          Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G23").Value & Chr(10)
        Mensagem = Mensagem & Range("G24").Value & Chr(10)
        Mensagem = Mensagem & Range("G25").Value & Chr(10)
        Mensagem = Mensagem & Range("G26").Value & Chr(10)
        Mensagem = Mensagem & Range("G28").Value & Chr(10)
        Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("A11").Value & Chr(10)
        Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
        Mensagem = Mensagem & Range("G31").Value & Chr(10)
        Mensagem = Mensagem & Range("G32").Value & Chr(10)
        Mensagem = Mensagem & Range("G33").Value & Chr(10)
        Mensagem = Mensagem & "www.leadernutrition.com.br"
         
End If

GoTo Aviso2
Aviso2:

         'A Mensagem que seguirá no corpo do e-mail
         .Body = Mensagem
         
         'Para quem vai a mensagem...
         .To = Range("C" & i).Value
         
         'Se for enviar com cópia
         'EMail.Cc = "dantas.mariana@emrpesa.com"
         
         'Arquivos a serem anexados
         .Attachments.Add Range("A2").Value & "" & Range("A15").Value
     '  EMail.Attachments.Add "C:UsersAndreDesktopPedidos GauerCatalogo Leader Nutrition.pdf"

If Sheets("CONFIG").Range("E27").Value = 4 And Range("A3").Value = 1 Then
         .Attachments.Add Range("A2").Value & Range("A26").Value
         .Attachments.Add Range("A2").Value & Range("A27").Value
         .Attachments.Add Range("A2").Value & Range("A28").Value
Else: End If
         
If Sheets("CONFIG").Range("E27").Value = 3 And Range("A3").Value = 1 Then
         .Attachments.Add Range("A2").Value & Range("A26").Value
         .Attachments.Add Range("A2").Value & Range("A27").Value
Else: End If

If Sheets("CONFIG").Range("E27").Value = 2 And Range("A3").Value = 1 Then
         .Attachments.Add Range("A2").Value & Range("A26").Value
Else: End If

If Sheets("CONFIG").Range("E27").Value = 4 And Range("A3").Value = 2 Then
         .Attachments.Add Range("A2").Value & Range("A31").Value
         .Attachments.Add Range("A2").Value & Range("A32").Value
         .Attachments.Add Range("A2").Value & Range("A33").Value
Else: End If
         
If Sheets("CONFIG").Range("E27").Value = 3 And Range("A3").Value = 2 Then
         .Attachments.Add Range("A2").Value & Range("A31").Value
         .Attachments.Add Range("A2").Value & Range("A32").Value
Else: End If

If Sheets("CONFIG").Range("E27").Value = 2 And Range("A3").Value = 2 Then
         .Attachments.Add Range("A2").Value & Range("A31").Value
Else: End If

                     
         'Para pré visualizar a mensagem usar Display. Para enviar direto sem visualizar, use Send
                  
  If Range("A23").Value = "DISPLAY" Then
                  
       .Display
         
       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
       .Display

GoTo Segue2

Else

       .Display
         
       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
       .Send

GoTo Segue2
Segue2:

End If
  
   Set OlApp = Nothing
     Set OlMensagem = Nothing
     
End With

 
Next

GoTo Fim
Fim:

    Range("C3:C505").Select
    Selection.ClearContents
    Range("Q1").Select
    Selection.ClearContents
    Range("Q2").Select
    Selection.ClearContents
    Range("A20").Select
    Selection.ClearContents
    Range("A23").Select
    Selection.ClearContents
    Range("B12").Select
    Selection.ClearContents
    
 Sheets("Config").Select
 
If Range("E15").Value = 9 Then
If Range("F29").Value = 1 Then
Range("F29").Value = 2
GoTo C
Else
End If

If Range("F29").Value = 2 Then
Range("F29").Value = 3
GoTo C
Else
End If

 If Range("F29").Value = 3 Then
    Range("F29").Value = 1
    
 Else
 End If
 
 Else
 End If
 
GoTo C
C:

Sheets(Loja).Select
    
If Range("A1").Value = "MUNDO VERDE" Or Range("A1").Value = "VIA VERDE" Or Range("A1").Value = "BRASIL" Then

GoTo Vamos
Else
End If

Sheets("Config").Select
GoTo Terminar

GoTo Vamos
Vamos:

  t = ActiveSheet.Range("G11")
  A = t + 1
  Application.ActiveSheet.Range("G11").Value = A
  
    Range("J10").Select
    Selection.Copy
    Sheets("CONFIG").Select
    Range("B28").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


   Sheets("Envios Individuais").Visible = False


Sheets(Loja).Select

If Range("A1").Value = "MUNDO VERDE" And Range("G11").Value = 26 Then
Range("G11").Value = 1

Sheets("CONFIG").Select
    Range("B28").Select
    Selection.ClearContents


Else
End If

If Range("A1").Value = "VIA VERDE" And Range("G11").Value = 9 Then
Range("G11").Value = 1

Sheets("CONFIG").Select
    Range("B28").Select
    Selection.ClearContents

Else
End If

If Range("A1").Value = "BRASIL" And Range("G11").Value = 9 Then
Range("G11").Value = 1

Sheets("CONFIG").Select
    Range("B28").Select
    Selection.ClearContents


Else
End If


'   Sheets(Revenda).Visible = False
  Sheets("Config").Select
   
 If Range("E20").Value = 1 Then
 If Sheets(Loja).Range("G11").Value = 1 Then
GoTo By
Else
GoTo Volte

End If
End If

GoTo By
By:

  Sheets(Revenda).Visible = False
    Sheets("MAPA").Visible = True
  
GoTo Terminar
Terminar:
  
If Range("E15").Value = 1 Or Range("E15").Value = 2 Or Range("E15").Value = 5 Or Range("E15").Value = 9 Then
GoTo bb
Else
End If

Range("C15").Value = 6
Range("C24").Value = 4
Range("E15").Value = 10
Range("E18").Value = 2
Range("E20").Value = 2
Range("D27").Value = 5
Range("C13").Value = 1

GoTo bb
bb:

If Range("A1").Value = "TESTE DE ENVIO" Then
  Sheets(Revenda).Visible = False
    Sheets("Envios Individuais").Visible = False
Else
End If
  Sheets(Revenda).Visible = False


End Sub
 
Postado : 13/06/2016 1:10 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

Bem gente nao sei o Por QuÊ ? mas acrescentei o ( Mensagem = "" ) no final antes de fazer o Next e deu certo, nao hou mais as duplicacoes do corpo da mensagem a partir do segundo email em diante.

Set OlApp = Nothing
Set OlMensagem = Nothing
Mensagem = ""

Porem ainda nao entendi porque a rotina abaixo funciona sem este acrescimo ????

If Range("B12").Value = 1 Then

Mensagem = " Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G2").Value & Chr(10) ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G5").Value & Chr(10) ' " Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G8").Value & Chr(10)
Mensagem = Mensagem & Range("G11").Value & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G14").Value & Chr(10)
Mensagem = Mensagem & Range("G15").Value & Chr(10)
Mensagem = Mensagem & Range("G16").Value & Chr(10)
Mensagem = Mensagem & "www.gauerdobrasil.com.br & www.g-actionsuplementos.com.br"

Else

Mensagem = " Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G19").Value & Chr(10) ' Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G22").Value & Chr(10) ' " Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G23").Value & Chr(10)
Mensagem = Mensagem & Range("G24").Value & Chr(10)
Mensagem = Mensagem & Range("G25").Value & Chr(10)
Mensagem = Mensagem & Range("G26").Value & Chr(10)
Mensagem = Mensagem & Range("G28").Value & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("G31").Value & Chr(10)
Mensagem = Mensagem & Range("G32").Value & Chr(10)
Mensagem = Mensagem & Range("G33").Value & Chr(10)
Mensagem = Mensagem & "www.leadernutrition.com.br"

End If

 
Postado : 13/06/2016 2:03 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico