Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Loop de envio de Em...
 
Notifications
Clear all

Loop de envio de Emails.

 
Página 1 / 4
2024 - VBA & Macros
58 Posts
2 Usuários
0 Reactions
4,832 Visualizações
RSS
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

Bom dia, tenho uma macro que envia corretamente emails em bloco de 99 emails. Porem o Gmail identifica isso como Span. Porem nao é pois envio as Lojas as quais mantenho contato.
EM algum lugar eu vi que para isso nao ocorrer eu nao poderia enviar nem por C/C e nem por CCo. Porem eu gostaria de enviar por CCo e isso causa o retorno de erro.

Entao acho ser a unica forma de fazer os envios seria um a um mesmo, mas para isso eu precisaria de uma Macro que funcionasse por LOOP, assim sendo poderia individualizar no assunto.

Como a Macro abaixo funciona corretamente em certo grupo de envio em uma de minhas contas de envio e nao funciona em outra conta Gmail.

eu queria entao desta forma adaptar na macro em questao, uma cadeia de comandos com este objetivo. Funcionaria assim:

Se a Celula Q22 estiver com o numeral ( 1 ) , entao a regra de envio sera a de loop enviando email por email em separado. Se a Celula Q22 estiver vazia, entao seguira normalmente a Macro em questao abaixo. Poderiamos para isso usar o GOTO e iniciar a Macro no final desta abaixo.

A pasta que estao os emails se chama ( EN ), e o o primeiro Email se inicia na :

celula G2 e o ultimo esta na Celula G99 Depois tem outra sequencia na
Celula I2 e o ultimo esta na Celula I99 depois tem outra sequencia na
Celula K2 e o ultimo esta na celula K99 .........
Celula M2 ......
Celula O2 .......
Celula Q2 ....
e assim vai ate a celula AG2 ate AG 99

Agradeço a todos que mais uma vez puderem me dar uma ajudinha.

André

Sub X_Lojas_Convites()

'  Enviar Convites Lojas

If Range("E11") = "" Then
Run "Copiar1"
GoTo Segue

Else

If Range("F11") = "" Then
Run "Copiar2"
Else

If Range("G11") = "" Then
Run "Copiar3"
Else

If Range("H11") = "" Then
Run "Copiar4"
Else

If Range("I11") = "" Then
Run "Copiar5"
Else

If Range("E12") = "" Then
Run "Copiar6"
Else

If Range("F12") = "" Then
Run "Copiar7"
Else

If Range("G12") = "" Then
Run "Copiar8"
Else

If Range("H12") = "" Then
Run "Copiar9"
Else

If Range("I12") = "" Then
Run "Copiar10"
Else

If Range("E13") = "" Then
Run "Copiar11"
Else

If Range("F13") = "" Then
Run "Copiar12"
Else

If Range("G13") = "" Then
Run "Copiar13"
Else

If Range("H13") = "" Then
Run "Copiar14"

 Else
   Run "Copiar1"

End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If


GoTo Segue
Segue:

'If Worksheets("EN").Range("C1").Value = "" Then
'MsgBox ("Não foi copiado os E-mails para serem enviados !")
'Sheets("EN").Visible = True
'' GoTo Fim
  '       Else
   '           End If

'Setting up the Excel variables.
    Dim OlApp As Outlook.Application
    Dim OlMensagem As Outlook.MailItem
    Dim iCounter    As Integer
    Dim Dest        As Variant
    Dim SDest       As String
    Dim Estado      As String
    Dim BuscaEstado As Range
    Dim AbrevEstado As String
    Dim Leitura     As String
    Dim contaEmail As String
    Dim idEmail As Integer
    Dim strbody As String
    Dim Loja        As String
    Loja = Range("A1")
    
    If Range("K4") = 1 Then
    
strbody = "<H2>" & _
        Sheets("Enviar Convites").Range("V2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets("Enviar Convites").Range("V6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets("Enviar Convites").Range("V10").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("V14").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z18").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z22").Value & _
        "<br><br>" & _
        "<br><br><B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & _
        "<br><br>"
    
GoTo Saltar
    
    Else
    End If

strbody = "<H2>" & _
        Sheets("Enviar Convites").Range("Z2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets("Enviar Convites").Range("Z6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets("Enviar Convites").Range("Z10").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z14").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z18").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z22").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z23").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z24").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z25").Value & _
        "<br><br>" & _
        Sheets("Enviar Convites").Range("Z26").Value & _
        "</H3>" & _
        "<br><br><B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & _
        "<br><br>"

GoTo Saltar
Saltar:

    Leitura = Sheets(Loja).Range("I7")
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Sheets(Estado).Visible = True

 Application.DisplayAlerts = False 'desabilite o alerta

        Range("L2").Select



    Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
    
    If BuscaEstado Is Nothing Then
        MsgBox "Estado não localizado"
        GoTo Fim
    Else
    
        AbrevEstado = ThisWorkbook.Worksheets(Loja).Cells(BuscaEstado.Row, 1).Value
    End If
    
' Preste atencao aqui
      contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value
    
    'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na     regiao do mapa.
    ThisWorkbook.Worksheets(AbrevEstado).Select
   
    iCounter = 2 'inicia na linha 2
   
    '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
            If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                            
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
            Else
                 Sheets(Estado).Visible = False
                 Sheets(Loja).Select
                
                GoTo Fim 'Senão sai da rotina
            End If
        End If
    Next
'-------------------------------------------------------------------------------
'Using the email, add multiple recipients, using a list of addresses in column C.
     With OlMensagem
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))  ' Linha 2 da coluna 3
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter
          
'     Sheets("parar").Select
     
          
    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .Display
       
If Sheets("Enviar Convites").Range("Q15").Value = 1 Then
       
       .BCC = SDest
       
Else
       
       .To = SDest
       
 End If
 
If Sheets("Enviar Convites").Range("K4").Value = 1 Then
  
       .Subject = "Tabela de Pedidos da Gauer do Brasil"
       
Else

       .Subject = "Tabela de Pedidos da Leader Nutrition"
       
End If
       
       .HTMLBody = strbody & "<br>" & .HTMLBody
       
If Sheets(Loja).Range("F1").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F1").Value & Sheets(Loja).Range("I1").Value
Else
    End If

If Sheets(Loja).Range("F2").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F2").Value & Sheets(Loja).Range("I2").Value
Else
    End If
If Sheets(Loja).Range("F3").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F3").Value & Sheets(Loja).Range("I3").Value
Else
    End If
If Sheets(Loja).Range("F4").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F4").Value & Sheets(Loja).Range("I3").Value
Else
    End If
       
       
If Sheets(Loja).Range("I6").Value = "SEND" Then
       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
       .Send
Else

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

Sheets("EN").Select
' Limpar Email Planilha EN ( Enviar Convites )
    Sheets("EN").Range("C1:C99").Select
    Selection.ClearContents
    Range("D1").Select

Sheets(Loja).Select
If Range("K12").Value = 105 Then
    Range("E11:I13").Select
    Selection.ClearContents
    
Else
End If

Sheets(Estado).Visible = False
   
GoTo Fim

   End With

    Exit Sub
Fim:
   'Clean up the Outlook application.
   Set BuscaEstado = Nothing
   Set OlMensagem = Nothing
   Set OlApp = Nothing
   
End Sub
 
Postado : 15/04/2016 7:54 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia Fazerbem,

Posso fazer uma mudança quase radical dando uma otimizada no código?
Vou almoçar agora e quando voltar dou uma olhada.

Qualquer coisa da o grito.
Abraço

 
Postado : 15/04/2016 8:56 am
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

Opa amigo, pode sim, veja que eu preciso destas partes, pois dependo disto pra outras areas funcionarem

If Range("I12") = "" Then
Run "Copiar10"
Else

If Range("E13") = "" Then
Run "Copiar11"
Else

If Range("F13") = "" Then
Run "Copiar12"
Else

E se nao for pedir muito, gostaria de acrescentar ao corpo do email uma imagem ao qual sera a minha assinatura, pode ser ? a proposito ja estou nisto a um bom tempo veja em :

viewtopic.php?f=10&t=18656

Grato amigo, grato mesmo !!

Andre

 
Postado : 15/04/2016 9:13 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Cara, como não consigo fazer os testes aqui, apenas executa e vê se funciona normal como antes depois dessa atualização:

Option Explicit

Sub X_Lojas_Convites()
'Setting up the Excel variables.
Dim OlApp           As Outlook.Application
Dim OlMensagem      As Outlook.MailItem
Dim wb              As Workbook
Dim wsEN            As Worksheet
Dim wsLoja          As Worksheet
Dim wsEstado        As Worksheet
Dim wsSendConvite   As Worksheet
Dim iCounter        As Integer
Dim Dest            As Variant
Dim SDest           As String
Dim Estado          As String
Dim BuscaEstado     As Range
Dim AbrevEstado     As String
Dim Leitura         As String
Dim contaEmail      As String
Dim idEmail         As Integer
Dim strbody         As String
Dim Loja            As String
Dim Caminho         As String
Dim Quebralin1      As String
Dim QuebraLin2      As String
Dim ContCopy        As Long
Dim i               As Long
Dim j               As Long
Dim w               As Long

    Set wb = ThisWorkbook
    Set wsEN = wb.Worksheets("EN")
    Set wsSendConvite = wb.Worksheets("Enviar Convites")
    Quebralin1 = "<br>"
    QuebraLin2 = "<br><br>"
    Caminho = "C:UsersAndreDesktopPedidos Gauer"
    ContCopy = 1
    

    '  Enviar Convites Lojas
    For j = 5 To 8
        For i = 11 To 13
            If wb.ActiveSheet.Cells(i, j).Value = "" Then
                Run "Copiar" & ContCopy
                GoTo Segue
            End If
            ContCopy = ContCopy + 1
        Next i
        ContCopy = ContCopy + 1
    Next j
    
    Run "Copiar1"
    
Segue:

    Loja = wb.ActiveSheet.Range("A1").Value
    Set wsLoja = wb.Worksheets(Loja)
    
    If wb.ActiveSheet.Range("K4").Value = 1 Then
        strbody = "<H2>" & _
                    wsSendConvite.Range("V2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("V6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("V10").Value & QuebraLin2 & _
                    wsSendConvite.Range("V14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    Else
        strbody = "<H2>" & _
                    wsSendConvite.Range("Z2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("Z6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("Z10").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z23").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z24").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z25").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z26").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    End If

Saltar:

    Leitura = wsLoja.Range("I7").Value
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Set wsEstado = wb.Worksheets(Estado)
    wsEstado.Visible = True

    Application.DisplayAlerts = False   'desabilite o alerta

    wb.ActiveSheet.Range("L2").Select

    Set BuscaEstado = wb.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
    
    If BuscaEstado Is Nothing Then
        MsgBox "Estado não localizado"
        GoTo Fim
    Else
        AbrevEstado = wsLoja.Cells(BuscaEstado.Row, 1).Value
    End If
    
    ' Preste atencao aqui
      contaEmail = wsLoja.Range("I8").Value
    
    'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na     regiao do mapa.
    wb.Worksheets(AbrevEstado).Select
   
    iCounter = 2 'inicia na linha 2
   
    '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
            If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
            Else
                 wsEstado.Visible = False
                 wsLoja.Select
                GoTo Fim 'Senão sai da rotina
            End If
        End If
    Next
'-------------------------------------------------------------------------------
'Using the email, add multiple recipients, using a list of addresses in column C.
    With OlMensagem
        For iCounter = 2 To WorksheetFunction.CountA(Columns(3))  ' Linha 2 da coluna 3
        
         'Sheets("Email").Select
                SDest = SDest & ";" & Cells(iCounter, 3).Value
        Next iCounter
          
    '     Sheets("parar").Select
         
              
        'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
           .Display
           
        If wsSendConvite.Range("Q15").Value = 1 Then
            .BCC = SDest
        Else
            .To = SDest
        End If
    
        If wsSendConvite.Range("K4").Value = 1 Then
            .Subject = "Tabela de Pedidos da Gauer do Brasil"
        Else
            .Subject = "Tabela de Pedidos da Leader Nutrition"
        End If
           
        .HTMLBody = strbody & Quebralin1 & .HTMLBody
           
        For i = 1 To 4
            If wsLoja.Range("F" & i).Value > 0 Then
                .Attachments.Add Caminho & wsLoja.Range("F" & i).Value & wsLoja.Range("I" & i).Value
            End If
        Next i
        
        
        .ReadReceiptRequested = Leitura ' confirmação de leitura
        .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
        
        If wsLoja.Range("I6").Value = "SEND" Then
            .Send
        Else
            .Display
        End If
    
        wsEN.Select
        ' Limpar Email Planilha EN ( Enviar Convites )
        wsEN.Range("C1:C99").ClearContents
        wsEN.Range("D1").Select
    
        wsLoja.Select
        If wsLoja.Range("K12").Value = 105 Then
            wsLoja.Range("E11:I13").ClearContents
        End If
    
        Sheets(Estado).Visible = False
       
        GoTo Fim

    End With

    Exit Sub
Fim:
   'Clean up the Outlook application.
    Set BuscaEstado = Nothing
    Set OlMensagem = Nothing
    Set OlApp = Nothing
    Set wb = Nothing
    Set wsEN = Nothing
    Set wsSendConvite = Nothing
    Set wsLoja = Nothing
    Set wsEstado = Nothing
   
End Sub

Se funcionar eu olho o loop para o envio.

Qualquer coisa da o grito.
Abraço

 
Postado : 15/04/2016 10:35 am
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

Ola amigao

esta parte do codigo abaixo nao funcionou no seu codigo , todo o restante parece que bateu certo

Este codigo abaixo funciona completando os conteudos das celulas E11:I13

assim : Ao final da macro em E11 aparece 1, E12 aparece 2 .......
E quando chega na celula I13 a soma das celulas vai dar 105 entao apaga o conteudo de E11:I13

Da forma que esta rodando aqui apenas a Celula E12 esta sendo inserida o numeral 2, se eu rodar de novo novamente vai pra celula E12, entendeu ?

Outra coisa, me daria pra por para no final do email aparecer uma imagem ? 

If Range("E11") = "" Then
Run "Copiar1"
GoTo Segue

Else

If Range("F11") = "" Then
Run "Copiar2"
Else

If Range("G11") = "" Then
Run "Copiar3"
Else

If Range("H11") = "" Then
Run "Copiar4"
Else

If Range("I11") = "" Then
Run "Copiar5"
Else

If Range("E12") = "" Then
Run "Copiar6"
Else

If Range("F12") = "" Then
Run "Copiar7"
Else

If Range("G12") = "" Then
Run "Copiar8"
Else

If Range("H12") = "" Then
Run "Copiar9"
Else

If Range("I12") = "" Then
Run "Copiar10"
Else

If Range("E13") = "" Then
Run "Copiar11"
Else

If Range("F13") = "" Then
Run "Copiar12"
Else

If Range("G13") = "" Then
Run "Copiar13"
Else

If Range("H13") = "" Then
Run "Copiar14"

Else
   Run "Copiar1"

End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
 
Postado : 15/04/2016 11:19 am
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

lembro que este codigo ficara , porem se a celula Q22 estiver com o numeral 1, entao ao inves de envair por bloco enviara um email de cada vez, por isso o loop. Dai o Gmail nao identificara se tratar de span

 
Postado : 15/04/2016 11:21 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

fazerbem,

não entendi.
isso:

If Range("E11") = "" Then
Run "Copiar1"
GoTo Segue

Else

If Range("F11") = "" Then
Run "Copiar2"
Else

If Range("G11") = "" Then
Run "Copiar3"
Else

If Range("H11") = "" Then
Run "Copiar4"
Else

If Range("I11") = "" Then
Run "Copiar5"
Else

If Range("E12") = "" Then
Run "Copiar6"
Else

If Range("F12") = "" Then
Run "Copiar7"
Else

If Range("G12") = "" Then
Run "Copiar8"
Else

If Range("H12") = "" Then
Run "Copiar9"
Else

If Range("I12") = "" Then
Run "Copiar10"
Else

If Range("E13") = "" Then
Run "Copiar11"
Else

If Range("F13") = "" Then
Run "Copiar12"
Else

If Range("G13") = "" Then
Run "Copiar13"
Else

If Range("H13") = "" Then
Run "Copiar14"

Else
   Run "Copiar1"

End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If

é a mesma coisa disso:

    For j = 5 To 8
        For i = 11 To 13
            If wb.ActiveSheet.Cells(i, j).Value = "" Then
                Run "Copiar" & ContCopy
                GoTo Segue
            End If
            ContCopy = ContCopy + 1
        Next i
        ContCopy = ContCopy + 1
    Next j
    
    Run "Copiar1"

Mas tenta mudar para isso:

    For i = 11 To 13
        For j = 5 To 8
            If wb.ActiveSheet.Cells(i, j).Value = "" Then
                Run "Copiar" & ContCopy
                GoTo Segue
            End If
            ContCopy = ContCopy + 1
        Next j
        ContCopy = ContCopy + 1
    Next i
    
    Run "Copiar1"

Qualquer coisa da o grito.
Abraço

 
Postado : 15/04/2016 11:43 am
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

agora ele marcou a celula E11=1, depois F11=2 , G11=3, H11=4, dai pulou a I11 que seria =5
e pulou para E12=6 dai pulou de novo a I12 e foi pra E13, entendeu ?

grato

 
Postado : 15/04/2016 12:16 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Cara, acho que agora estou entendendo, mas como não sei como está o código "Copiar1, 2, 3.. ..." não sei o que está acontecendo...
kkkkkkkkk

Na lógica da programação, faz a mesma coisa...

usa assim:

Option Explicit

Sub X_Lojas_Convites()
'Setting up the Excel variables.
Dim OlApp           As Outlook.Application
Dim OlMensagem      As Outlook.MailItem
Dim wb              As Workbook
Dim wsEN            As Worksheet
Dim wsLoja          As Worksheet
Dim wsEstado        As Worksheet
Dim wsSendConvite   As Worksheet
Dim iCounter        As Integer
Dim Dest            As Variant
Dim SDest           As String
Dim Estado          As String
Dim BuscaEstado     As Range
Dim AbrevEstado     As String
Dim Leitura         As String
Dim contaEmail      As String
Dim idEmail         As Integer
Dim strbody         As String
Dim Loja            As String
Dim Caminho         As String
Dim Quebralin1      As String
Dim QuebraLin2      As String
Dim ContCopy        As Long
Dim i               As Long
Dim j               As Long
Dim w               As Long

    Set wb = ThisWorkbook
    Set wsEN = wb.Worksheets("EN")
    Set wsSendConvite = wb.Worksheets("Enviar Convites")
    Quebralin1 = "<br>"
    QuebraLin2 = "<br><br>"
    Caminho = "C:UsersAndreDesktopPedidos Gauer"

    '  Enviar Convites Lojas
    For i = 11 To 13
        For j = 5 To 8
            ContCopy = ContCopy + 1
            If wb.ActiveSheet.Cells(i, j).Value = "" Then
                Run "Copiar" & ContCopy
                GoTo Segue
            End If
        Next j
    Next i
    
    Run "Copiar1"
    
Segue:

    Loja = wb.ActiveSheet.Range("A1").Value
    Set wsLoja = wb.Worksheets(Loja)
    
    If wb.ActiveSheet.Range("K4").Value = 1 Then
        strbody = "<H2>" & _
                    wsSendConvite.Range("V2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("V6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("V10").Value & QuebraLin2 & _
                    wsSendConvite.Range("V14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    Else
        strbody = "<H2>" & _
                    wsSendConvite.Range("Z2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("Z6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("Z10").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z23").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z24").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z25").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z26").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    End If

Saltar:

    Leitura = wsLoja.Range("I7").Value
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Set wsEstado = wb.Worksheets(Estado)
    wsEstado.Visible = True

    Application.DisplayAlerts = False   'desabilite o alerta

    wb.ActiveSheet.Range("L2").Select

    Set BuscaEstado = wb.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
    
    If BuscaEstado Is Nothing Then
        MsgBox "Estado não localizado"
        GoTo Fim
    Else
        AbrevEstado = wsLoja.Cells(BuscaEstado.Row, 1).Value
    End If
    
    ' Preste atencao aqui
      contaEmail = wsLoja.Range("I8").Value
    
    'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na     regiao do mapa.
    wb.Worksheets(AbrevEstado).Select
   
    iCounter = 2 'inicia na linha 2
   
    '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
            If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
            Else
                 wsEstado.Visible = False
                 wsLoja.Select
                GoTo Fim 'Senão sai da rotina
            End If
        End If
    Next
'-------------------------------------------------------------------------------
'Using the email, add multiple recipients, using a list of addresses in column C.
    With OlMensagem
        For iCounter = 2 To WorksheetFunction.CountA(Columns(3))  ' Linha 2 da coluna 3
        
         'Sheets("Email").Select
                SDest = SDest & ";" & Cells(iCounter, 3).Value
        Next iCounter
          
    '     Sheets("parar").Select
         
              
        'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
           .Display
           
        If wsSendConvite.Range("Q15").Value = 1 Then
            .BCC = SDest
        Else
            .To = SDest
        End If
    
        If wsSendConvite.Range("K4").Value = 1 Then
            .Subject = "Tabela de Pedidos da Gauer do Brasil"
        Else
            .Subject = "Tabela de Pedidos da Leader Nutrition"
        End If
           
        .HTMLBody = strbody & Quebralin1 & .HTMLBody
           
        For i = 1 To 4
            If wsLoja.Range("F" & i).Value > 0 Then
                .Attachments.Add Caminho & wsLoja.Range("F" & i).Value & wsLoja.Range("I" & i).Value
            End If
        Next i
        
        
        .ReadReceiptRequested = Leitura ' confirmação de leitura
        .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
        
        If wsLoja.Range("I6").Value = "SEND" Then
            .Send
        Else
            .Display
        End If
    
        wsEN.Select
        ' Limpar Email Planilha EN ( Enviar Convites )
        wsEN.Range("C1:C99").ClearContents
        wsEN.Range("D1").Select
    
        wsLoja.Select
        If wsLoja.Range("K12").Value = 105 Then
            wsLoja.Range("E11:I13").ClearContents
        End If
    
        Sheets(Estado).Visible = False
       
        GoTo Fim

    End With

    Exit Sub
Fim:
   'Clean up the Outlook application.
    Set BuscaEstado = Nothing
    Set OlMensagem = Nothing
    Set OlApp = Nothing
    Set wb = Nothing
    Set wsEN = Nothing
    Set wsSendConvite = Nothing
    Set wsLoja = Nothing
    Set wsEstado = Nothing
   
End Sub

Qualquer coisa da o grito.
Abraço

 
Postado : 15/04/2016 12:19 pm
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

tudo funcionou direito, mas agora que vi e fiz uma modificacao em :

For i = 11 To 13
For j = 5 To 8

para

For i = 11 To 13
For j = 5 To 9

agora marcou certo, mas quando chegou em E12 ele pulou para para F12, ficando E12 em branco

 
Postado : 15/04/2016 12:31 pm
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

eu tenho aqui copiar de 1 a 14

 
Postado : 15/04/2016 12:35 pm
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

pronto amigo, testei aqui ao mudar para 9 deu tudo certo e no fina ele zerou tudo !!!

Grato

So falta agora inserir a imagem no corpo do email essa imagem sera a minha assinatura.

 
Postado : 15/04/2016 12:41 pm
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

a sim falto o loop de email 1 de cada conforme se celula Q22= 1 Then inicia o envio individual de cada email conforme G2 a G99 depois I2 a I99 ...

 
Postado : 15/04/2016 12:50 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Cara, não funcionou o código para inserir a imagem no tópico que enviou não?

Quanto ao loop, tenta assim:

Option Explicit

Sub X_Lojas_Convites()
'Setting up the Excel variables.
Dim OlApp           As Outlook.Application
Dim OlMensagem      As Outlook.MailItem
Dim wb              As Workbook
Dim wsEN            As Worksheet
Dim wsLoja          As Worksheet
Dim wsEstado        As Worksheet
Dim wsSendConvite   As Worksheet
Dim iCounter        As Integer
Dim Dest            As Variant
Dim SDest           As String
Dim Estado          As String
Dim BuscaEstado     As Range
Dim AbrevEstado     As String
Dim Leitura         As String
Dim contaEmail      As String
Dim idEmail         As Integer
Dim strbody         As String
Dim Loja            As String
Dim Caminho         As String
Dim Quebralin1      As String
Dim QuebraLin2      As String
Dim ContCopy        As Long
Dim i               As Long
Dim j               As Long
Dim w               As Long

    Set wb = ThisWorkbook
    Set wsEN = wb.Worksheets("EN")
    Set wsSendConvite = wb.Worksheets("Enviar Convites")
    Quebralin1 = "<br>"
    QuebraLin2 = "<br><br>"
    Caminho = "C:UsersAndreDesktopPedidos Gauer"

    '  Enviar Convites Lojas
    For i = 11 To 13
        For j = 5 To 9
            ContCopy = ContCopy + 1
            If wb.ActiveSheet.Cells(i, j).Value = "" Then
                Run "Copiar" & ContCopy
                GoTo Segue
            End If
        Next j
    Next i
    
    Run "Copiar1"
    
Segue:

    Loja = wb.ActiveSheet.Range("A1").Value
    Set wsLoja = wb.Worksheets(Loja)
    
    If wb.ActiveSheet.Range("K4").Value = 1 Then
        strbody = "<H2>" & _
                    wsSendConvite.Range("V2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("V6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("V10").Value & QuebraLin2 & _
                    wsSendConvite.Range("V14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    Else
        strbody = "<H2>" & _
                    wsSendConvite.Range("Z2").Value & _
                "</H2>" & _
                "<H3 style='color: #870c0c'>" & _
                    wsSendConvite.Range("Z6").Value & _
                "</H3>" & _
                "<H3>" & _
                    wsSendConvite.Range("Z10").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z14").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z18").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z22").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z23").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z24").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z25").Value & QuebraLin2 & _
                    wsSendConvite.Range("Z26").Value & _
                "</H3>" & _
                QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
    End If

Saltar:

    Leitura = wsLoja.Range("I7").Value
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Set wsEstado = wb.Worksheets(Estado)
    wsEstado.Visible = True

    Application.DisplayAlerts = False   'desabilite o alerta

    wb.ActiveSheet.Range("L2").Select

    Set BuscaEstado = wb.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
    
    If BuscaEstado Is Nothing Then
        MsgBox "Estado não localizado"
        GoTo Fim
    Else
        AbrevEstado = wsLoja.Cells(BuscaEstado.Row, 1).Value
    End If
    
    ' Preste atencao aqui
      contaEmail = wsLoja.Range("I8").Value
    
    'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na     regiao do mapa.
    wb.Worksheets(AbrevEstado).Select
   
    iCounter = 2 'inicia na linha 2
   
    'Create the Outlook application and the empty email.
    Set OlApp = CreateObject("Outlook.Application")


    For col = 7 To 33
        For lin = 2 To 99
            If wsEN.Cells(lin, col).Value = Empty Then Next i
        
            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
                    If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                        idEmail = w 'Define o id da conta para o comando enviar
                        Exit For 'Sai do laço
                    Else
                         wsEstado.Visible = False
                         wsLoja.Select
                        GoTo Fim 'Senão sai da rotina
                    End If
                End If
            Next
        '-------------------------------------------------------------------------------
        
        'Using the email, add multiple recipients, using a list of addresses in column C.
            With OlMensagem
            
                .Display
                   
                If wsSendConvite.Range("Q15").Value = 1 Then
                    .BCC = wsEN.Cells(lin, col).Value
                Else
                    .To = wsEN.Cells(lin, col).Value
                End If
            
                If wsSendConvite.Range("K4").Value = 1 Then
                    .Subject = "Tabela de Pedidos da Gauer do Brasil"
                Else
                    .Subject = "Tabela de Pedidos da Leader Nutrition"
                End If
                   
                .HTMLBody = strbody & Quebralin1 & .HTMLBody
                
                For i = 1 To 4
                    If wsLoja.Range("F" & i).Value > 0 Then
                        .Attachments.Add Caminho & wsLoja.Range("F" & i).Value & wsLoja.Range("I" & i).Value
                    End If
                Next i
                
                .ReadReceiptRequested = Leitura ' confirmação de leitura
                .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
                
                If wsLoja.Range("I6").Value = "SEND" Then
                    .Send
                Else
                    .Display
                End If
            
                wsEN.Select
                ' Limpar Email Planilha EN ( Enviar Convites )
                wsEN.Range("C1:C99").ClearContents
                wsEN.Range("D1").Select
            
                wsLoja.Select
                If wsLoja.Range("K12").Value = 105 Then
                    wsLoja.Range("E11:I13").ClearContents
                End If
            
                Sheets(Estado).Visible = False
               
                GoTo Fim
        
            End With
    
        Next lin
    Next col

    Exit Sub
Fim:
   'Clean up the Outlook application.
    Set BuscaEstado = Nothing
    Set OlMensagem = Nothing
    Set OlApp = Nothing
    Set wb = Nothing
    Set wsEN = Nothing
    Set wsSendConvite = Nothing
    Set wsLoja = Nothing
    Set wsEstado = Nothing
   
End Sub

Qualquer coisa da o grito.
Abraço

 
Postado : 15/04/2016 1:30 pm
 fazerbem
(@fazerbem)
Posts: 0
New Member
Topic starter
 

ao rodar a macro deu erro aqui, e parou no FOR - For col = 7 To 33

For col = 7 To 33
For lin = 2 To 99
If wsEN.Cells(lin, col).Value = Empty Then Next i

erro de compilacao variavel nao definida

 
Postado : 15/04/2016 3:02 pm
Página 1 / 4
Forum Jump:
  Tópico Anterior
Próximo Tópico