Bom dia

Eu gostaria de saber se existe como incluir na Macro abaixo, que esta funcionando adequadamente, uma intrução para que no dia Tal e Hora Tal, seja enviado o email automaticamente.

Grato

André Luiz

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"

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

'If Range("H12") = "" Then
'Run "Copiar10"

 Else
   Run "Copiar1"

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")

strbody = "<H2>" & _
        Sheets("Mensagens").Range("L3").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets("Mensagens").Range("L4").Value & _
        "</H3>" & _
        "<H4>" & _
        Sheets("Mensagens").Range("L5").Value & _
        "<br><br>" & _
        Sheets("Mensagens").Range("L6").Value & _
        "<br><br>" & _
        Sheets("Mensagens").Range("L7").Value & _
        "<br><br>" & _
        Sheets("Mensagens").Range("L8").Value & _
        "</H4>" & _
        "<br><br><B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & _
        "<br><br>" & _
        "<B>Atenciosamente, André Luiz</B>"

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

 Application.DisplayAlerts = False 'desabilite o alerta

    Sheets("MENSAGENS").Select
    Range("E6:H7").Select
    Selection.Copy
    Sheets(Loja).Select
    Range("F3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    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 = 1
   
    '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 = 1 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter
          
    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .Display
       .BCC = SDest
       .Subject = "Tabela de Pedidos"
      
       .HTMLBody = strbody & "<br>" & .HTMLBody
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F1").Value & Sheets(Loja).Range("I1").Value
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("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
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