Sem problemas cara, preciso apenas dessa parte em específico mesmo...

Vou dar uma olhada aqui...

Cara, não entendi ainda o real objetivo desses "Copiar.. ...".
Qual a necessidade disso?

Faz o teste:

Sub Copiar1()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("G1:G99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("E11").Value = "1"

End Sub

Sub Copiar2()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("I1:I99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "2"

End Sub

Sub Copiar3()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("K1:K99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "3"

End Sub

Sub Copiar4()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("M1:M99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "4"
    
End Sub

Sub Copiar5()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("O1:O99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "5"

End Sub

Sub Copiar6()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("Q1:Q99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "6"

End Sub

Sub Copiar7()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("S1:S99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "7"
    
End Sub

Sub Copiar8()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("U1:U99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "8"
    
End Sub

Sub Copiar9()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("W1:W99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "9"
    
End Sub

Sub Copiar10()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("Y1:Y99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "10"
    
End Sub

Sub Copiar11()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("AA1:AA99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "11"
    
End Sub

Sub Copiar12()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("AC1:AC99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "12"
    
End Sub

Sub Copiar13()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("AE1:AE99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "13"
    
End Sub

Sub Copiar14()

' Esta macro copiar os Emails dos Convites

    Sheets("EN").Visible = True
    Sheets("EN").Range("AG1:AG99").Copy
    Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("D1").Select

    Sheets("Enviar Convites").Range("F11").Value = "14"
    
End Sub


Option Explicit
Dim assinatura As Variant

Public Function pega_assinatura(ByVal sFile As String) As String 'Dick Kusleika
Dim fso As Object
Dim ts As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    
    pega_assinatura = ts.ReadAll
    ts.Close

    Set fso = Nothing
    Set ts = Nothing
    
End Function

Sub XA_Lojas_Convites()
'Setting up the Excel variables.
Dim olapp           As Outlook.Application
Dim OlMensagem      As Outlook.MailItem
Dim objMail         As 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 CaminhoAssin    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
Dim Col             As Long
Dim Lin             As Long

    Set wb = ThisWorkbook
    Set wsEN = wb.Worksheets("EN")
    Set wsSendConvite = wb.Worksheets("Enviar Convites")
    Set olapp = Outlook.Application
    Set objMail = olapp.CreateItem(olMailItem) 'Create mail item
    Quebralin1 = "<br>"
    QuebraLin2 = "<br><br>"
    Caminho = "C:UsersAndreDesktopPedidos Gauer"
    CaminhoAssin = "C:Assinaturas"
    
'------------------------------------------------------------
    
    If Range("I8").Value = "Amigo Lojista" Or Range("I8").Value = "Vendas Energy" Then
        assinatura = pega_assinatura(CaminhoAssin & "Amigo.htm")
    Else
        If Range("I8").Value = "Gauer do Brasil - André" Or Range("I8").Value = "Vendas Gauer" Then
            assinatura = pega_assinatura(CaminhoAssin & "Gauer.htm")
        Else
            assinatura = pega_assinatura(CaminhoAssin & "Leader.htm")
        End If
    End If

    '  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")
    
    If wb.ActiveSheet.Cells(22, 11).Value <> 1 Then GoTo Bloco
    
    For Col = 7 To 33
        For Lin = 2 To 99
            If wsEN.Cells(Lin, Col).Value = Empty Then GoTo NextLin
Bloco:
            
            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
                
                If wb.ActiveSheet.Cells(22, 11).Value <> 1 Then GoTo BlocoEndereco: SDest = wsEN.Cells(Lin, Col).Value
                
                For iCounter = 2 To WorksheetFunction.CountA(Columns(3))  ' Linha 2 da coluna 3
                
                 'Sheets("Email").Select
                    SDest = SDest & ";" & Cells(iCounter, 3).Value
                Next iCounter
                  
BlocoEndereco:
                  
            '     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
        '------------------------------------------------------------------
                .BodyFormat = olFormatHTML
                .HTMLBody = strbody & Quebralin1 & assinatura & .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
        
        If wb.ActiveSheet.Cells(22, 11).Value <> 1 Then GoTo FimBloco

NextLin:
        Next Lin
NextCol:
    Next Col
    
FimBloco:

    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

Cara, não entendi ainda o real objetivo desses "Copiar.. ...".
Qual a necessidade disso?

seria copiar Coluna G para para coluna C, fazer o envio e ao final em E11:I13 da aba enviar convites me direcionar quantos emails ja enviei.
Nao sou tao expert como vcs, dai fiz os codigos com a ajuda de muitos aqui e pesquisa na net e deu nisso ai. Se quiser exemplificar de forma que funcione, pois aqui este funciona, serei grato.

Vou testar seu codigo aqui

Entendi....

Pergunto porque entendo essa situação de que as vezes por falta de um conhecimento aprofundado no assunto (apesar de eu não ser tão expert assim), as vezes não temos uma visão de algumas possibilidades que podemos fazer... Porém, não tenho acesso completo à planilha, então pode ter algum outro objetivo, por isso pergunto...

Bom... Como não conheço muito bem a planilha nem mesmo a utilizo, pra mim está bem confuso. Fico perdido nas informações de "onde fica o que"...
Eu utilizaria formulários. Mas isso tomaria muito tempo e meio receio é de iniciar uma coisa e deixar inacabado, causando transtornos em uma coisa que já funcionava antes...

Vou fazer um teste aqui e depois me fala.
São somente "GAUER DO BRASIL" e "LEADER NUTRITION" podendo ser Misto né?

Vou fazer um teste aqui e depois me fala.
São somente "GAUER DO BRASIL" e "LEADER NUTRITION" podendo ser Misto né?

isso mesmo.

Sendo que a plan que te enviei nao altera em nada no restante das minhas outras abas, por isso te enviei,

e nao vi como ainda mandar os emails individuais, com a Celula Q22 marcada =1

Marcando ou nao 1 mandou em lote

ANdre

Deu erro aqui

Set wsEstado = wb.Worksheets(Estado)

Tá aqui:
If wb.ActiveSheet.Cells(22, 11).Value <> 1 Then GoTo Bloco

Os emails tem de estar separados por colunas na Sheet "EN"? Tem algum motivo? Ou pode deixar tudo junto?

O motivo real que deixei separados por colunas, e porque o envio maximo no Gmail sao 500 envios ao dia sendo 100 por bloco, so por isso fiz assim.

Mas If wb.ActiveSheet.Cells(22, 11).Value <> 1 Then GoTo Bloco

22,11 cai na linha 22 e coluna k

Q22 cai na coluna 17 ( 22,17 ) vou trocar entao aqui

Entendi.
Nisso você faz o rodízio de aproximadamente 5 blocos a cada email por dia né?
Você tem apenas uma conta de email para fazer isso enviando apenas 500 por dia? Ou tem dois emails que após o envio de 500 emails você utiliza outro email no mesmo dia?

Falha nossa.... kkkkkk
Blz, pode trocar...

tem ainda este erro

Set wsEstado = wb.Worksheets(Estado)

e

tenho varios emails que uso no Gmail

por saber que tenho limite diarios de 500

dai ou envio a continuacao no dia seguinte ou troco a conta de email em celula Q4

Nisso você faz o rodízio de aproximadamente 5 blocos a cada email por dia né?
Você tem apenas uma conta de email para fazer isso enviando apenas 500 por dia? Ou tem dois emails que após o envio de 500 emails você utiliza outro email no mesmo dia?

Por isso fiz as Macros copiar de 1 a 14

Envio o bloco G2:G99 , que contem 99 emails
depois I2:I99 que contem mais 99 emails e assim sucessivamente, depois quando chegar no ultimo bloco em AG2:AG99 a Celula K12 em aba Enviar convites é zerada e dai sei que envie a todos !

Entendi.
Vou pensar em algo.

Cara, esse "Estado" está puxando a informação de "Application.Caller" que Retorna informações sobre como o Visual Basic foi chamado.
Esse "Application.Caller" já tinha... não sei bem como é para funcionar... Se não me engano vai retornar "EN", caso seja clicado no símbolo gigante de email.

TENTA mudar para isso:
Set wsEstado = wb.Sheets(Estado)

sim estava funcionando ate esta sua ultima atualizacao, nao sei que ocorreu, tanto que comparei as linhas proximas com a anterior e estao iguais, mas vou mudar aqui pera ai. deu mesmo erro.

vou ver aqui o que ocorreu e se for o caso te envio a tabela com a macro

O que é esse negócio de Estado? Onde vai isso?