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

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

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

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

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

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

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

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

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

eu tenho aqui copiar de 1 a 14

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.

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 ...

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

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