na Celula A3, numas outras ABAS uso uma Macro parecida onde aparece a selecao usando o mapa do Brasil.

Por isso que em Set BuscaEstado = wb.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)

em outras Abas vai de A3: A32

Bom, basicamente nada funciona ainda.
Estou estruturando.
Mas dá uma olhada.

Estou indo para a facul agora.
Até amanhã.

Qualquer coisa da o grito.
Abraço

Bom Dia Bernardo

Tive uma ideia,

Para que todos os emails ficassem na mesma coluna, entao teria que ter uma rotina que caso escolhido o envio em bloco com a celula Q22=1, entao houvesse um contador de envio que enviaria em blocos de 99 emails e ao chegar o limite de envios diarios do Gmail que e de 500, entao aparecesse uma mensagem me pendindo para haver a troca do email que esta sendo usado, pois tenho 5 contas de envio.

No caso dos envios individuais seguiria o mesmo porem também respeitando o limite dos 500 e solicitando a troca do email usado, se sim continua se não interrompe a macro nos dois caso.

Vou aguardar entao ficar pronto a macro e enquanto isso vou usando a anterior sem o erro listado.

Cara, isso é simples.
A gente coloca....

Dá uma olhada...
Qualquer coisa da o grito.
Abraço

opaaaaaa, vou olhar daqui a pouco e te grito parceirao, estou terminando um video aqui da representacao de suplementos que vai entar no meu face aos lojsitas.

Cara ficou muito bom , mas otimo !

Porem fui no formulario cliquei em enviar emails e nao aconteceu nada.

e no link onde ficava onde a macro, deu erro tb

Nao testei na minha planilha, testei direto na sua

Cara, ainda não está funcionando. Estou estruturando ainda.
Fico perdido naquela planilha do jeito que tava...
Estou estruturando primeiro para depois "fazer funcionar".... O que preciso é estruturar tudo que for preciso para a planilha, tudo que for previsível... Para que seja prático de mexer no formulário e poder enviar os emails...

Bom dia, não é a toa que vc é o ninja no excel. Vai ficar muito bom mesmo.
Qualquer duvida é so gritar.

Bernardo bom dia e atodos do forum.

Se não for pedir muito, neste formulario que esta organizando, seria possivel incluir nele o nome da loja e telefone para que esta tela alem de enviar emails funcionasse também com nome da pessoa e telefones (2) ? Dai quando eu quiser enviar o email individual, poderia incluir no assunto aos cuidados de fulano de tal. O telefone seria somente pra constar .
Se enviar em bloco dai seguiria o modo normal.

Grato Bernardo.

Andre

Cara, dá sim.
Na verdade estou enviando para você ver e me falar o que é para colocar ou tirar pra depois já fazer de uma vez, pra depois não ter que ficar modificando demais, ficar adaptando demais e virar uma gambiarra...
Mas só na segunda olho isso...
Feriado e final de semana nem mexo em computador... A empresa emendou o feriado...
Estou no celular...

Qualquer coisa da o grito.
Abraço

Cara, dá sim.
Na verdade estou enviando para você ver e me falar o que é para colocar ou tirar pra depois já fazer de uma vez, pra depois não ter que ficar modificando demais, ficar adaptando demais e virar uma gambiarra...

Bom dia Bernardo, da forma que está, está excelente, porem vou expor o que eu de fato gostaria.

1- No envio de emails individuais, eu gostaria que houvesse 2 opcoes,
- opcao 1: O email seria enviado somente ao email especificado e nada mais ( macro se encerra apenas no envio do email , anotado em um novo campo desta Useform )
- Opcao 2: Os emails sao enviados individualmente um a um conforme os emails descritos na coluna C2 em diante. Caso o numero de emails descritos em Coluna C for maior que 500, a macro interrompe o Loop e me dando o aviso que o numero limite de envio daquele Email usado no envio atingiu seu limite diario. Lembrando que o Gmail me permite o envio de 500 emails diarios.

2- Favor adaptar um temporizador para que de tempo de carregar as imagens de minhas assinaturas no corpo do email, se nao fizer isso o email é enviado com uma imagem em miniatura. Falo isso porque uso uma outra macro aqui em outras abas e tive que por este temporizador,( 1s ) , ai a imagem de assinatura passou ir certa.

Pus antes do .Send
'Temporizador

Application.Wait VBA.Now + TimeValue("00:00:01")

3- Queria saber se vou poder aplicar esta Useform em minha Outra Macro de Envio chamada X_Lojas. Ao contrario desat que te passei, esta outra é destinada a Lojas que ja faço vendas, e abaixo disponibilizo a mesma. Se nao teria muit amodificacao conforme a macro abaixo ?

Grato

Sub X_Lojas()

'  Lojas Gerais

'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")
    Dim Assunto     As String
    Assunto = Range("L1")
    
'--------------------------------------------------------
    Dim objMail As MailItem
    Set olapp = Outlook.Application
    'Create mail item
    Set objMail = olapp.CreateItem(olMailItem)
'------------------------------------------------------------

If Range("I8").Value = "Amigo Lojista" Or Range("I8").Value = "Vendas Energy" Then
  
      assinatura = pega_assinatura("C:AssinaturasAmigo.htm")
      
Else
      
If Range("I8").Value = "Gauer do Brasil - André" Or Range("I8").Value = "Vendas Gauer" Then
  
      assinatura = pega_assinatura("C:AssinaturasGauer.htm")
  
Else

      assinatura = pega_assinatura("C:AssinaturasLeader.htm")

End If
End If

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

  If Sheets(Loja).Range("K4").Value = "" Then
  MsgBox ("Qual Empresa associar esta Mensagem 1-Gauer do Brasil ou 2-Leader Nutrition ?")
  Range("K4").Select
   
 GoTo Fim
 Else
 End If
        
    
  If Sheets(Loja).Range("Q4").Value = "" Then
  MsgBox ("A conta de E-mail não foi associada !")
  
 
 GoTo Fim
 Else
 End If
    
        
 If Sheets(Loja).Range("F7").Value = 1 Then
 
 strbody = "<H2>" & _
        Sheets(Loja).Range("AD2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("AD6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("AD10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("AD14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("AD18").Value & _
        "<br><br>"
 
GoTo Continuar
 
Else
        
        
 If Sheets(Loja).Range("K4").Value = 1 Then
    
strbody = "<H2>" & _
        Sheets(Loja).Range("V2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("V6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("V10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V18").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V22").Value & _
        "<br><br>"
    
    Else
         
strbody = "<H2>" & _
        Sheets(Loja).Range("Z2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("Z6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("Z10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z18").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z22").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z23").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z24").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z25").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z26").Value & _
        "<br><br>"

End If
End If

GoTo Continuar
Continuar:


    Leitura = Sheets(Loja).Range("I7")
    
  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular2
 Else
 End If
 
 If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular2
 Else
 End If
 
 If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular2
 Else
 End If
  
  
  If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular2
 Else
 End If
    
  If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular2
 Else
 End If
    
    
    
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Sheets(Estado).Visible = True

GoTo Pular2
Pular2:

 Application.DisplayAlerts = False 'desabilite o alerta

'------------------------------------------------------------
'DVitaminas/SNC/......

 If Sheets(Loja).Range("E15").Value = 1 Then
 
 GoTo Pular
Else
End If
'-----------------------------------------------------------
    Range("L2").Select

    Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A32").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
         
GoTo Pular
Pular:
    
' Preste atencao aqui
      contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value
    
  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular3
 Else
 End If
      
   If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular3
 Else
 End If
    
    
    '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
   
GoTo Pular3
Pular3:
   
   If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "SNC" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
   If Sheets(Loja).Range("A1").Value = "Farmacias" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
 
    If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
    If Sheets(Loja).Range("A1").Value = "Academias" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
    
    iCounter = 1
   
 GoTo Proximo1
Proximo1:
   
    'Create the Outlook application and the empty email.
    Set olapp = CreateObject("Outlook.Application")
Set OlMensagem = olapp.CreateItem(0)

'------------------------------------------------------------------------------
   Dim w
   '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 Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Proximo
 Else
 End If
        
   If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Proximo
 Else
 End If
 
    If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Proximo
 Else
 End If

   If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Proximo
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Proximo
 Else
 End If
    
    
    If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                            
  GoTo Proximo
Proximo:
                
                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
      
If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If
       
       
If Sheets(Loja).Range("A1").Value = "SNC" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If

If Sheets(Loja).Range("A1").Value = "Farmacias" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If

If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2


Else
End If

If Sheets(Loja).Range("A1").Value = "Academias" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2


Else
End If
       
       
       
       For iCounter = 1 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Proximo2:

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



'---------------------------------------------------------------
          
    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .Display
       
If Range("Q15").Value = 1 Then
       
       .BCC = SDest
       
Else

If Sheets(Loja).Range("S10").Value = 1 Then

       .BCC = SDest
       
 Else
       
       .To = SDest
       
 End If
 End If
 
       .Subject = Assunto '"Tabela de Pedidos"
'----------------------------------------------------
      .BodyFormat = olFormatHTML
'----------------------------------------------------
       .HTMLBody = strbody & assinatura & .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 GauerBanner" & 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 GauerBanner" & Sheets(Loja).Range("F4").Value & Sheets(Loja).Range("I4").Value
Else
    End If
       
       
     ' Sheets(s).Select
       
If Sheets(Loja).Range("I6").Value = "SEND" Then
       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = olapp.Session.Accounts.Item(idEmail)
       
'-------------------------------------------------------
'Temporizador

Application.Wait VBA.Now + TimeValue("00:00:01")
'-------------------------------------------------------------

       .Send
Else

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

Sheets(Loja).Select

  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular4
 Else
 End If


  If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular4
 Else
 End If

Sheets(Estado).Visible = False
   
GoTo Pular4
Pular4:
   
GoTo Fim


   

    Exit Sub
Fim:
   'Clean up the Outlook application.
   Set BuscaEstado = Nothing
   Set OlMensagem = Nothing
   Set olapp = Nothing
   
   End With
   
   
End Sub

ola Bernardo, mandei a MP

Da uma olhada...

Estou meio sem tempo para mexer, mas está saindo.
No manuseio da planilha com o intuito de enviar os emails, tem mais alguma informação na qual seria necessário acrescentar?