Excel Excel - Macro avaliar valores repetidos e copiar em email

[Vitor Hugo Ataide Almeida]

Caros, estou precisando de ajuda com uma macro.

 

Tenho uma planilha que envia e-mails automáticos com base na linha, se em determinada coluna o valor tiver abaixo de 20% ele encaminhará um email para o endereço de email contido em determinada coluna, acontece que as vezes possuem e-mails repetidos e gostaria que ele enviasse apenas um email com a informação de todas as respectivas linhas.

 

Portanto preciso de uma fórmula que avalie:

 

Se existem valores duplicados na coluna "G"

Caso sim, copie as informações das respectivas linhas em um mesmo e-mail.

 

'Enviar email
Sub Enviar_email(ByVal lLogin As String, ByVal lAR As String, ByVal lInvalidas As String, ByVal lValidas As String, ByVal lTotal As String, ByVal lPorcentagem As String, ByVal lEmail As String)
    Dim enderecos As Range
    Dim celula As Range
    Dim anexo As String
    Dim r As Integer
    Dim fim
    Dim enviar
    Dim objOlAppApp As Outlook.Application
    Dim objOlAppMsg As Outlook.MailItem
    Dim objOlAppRecip As Outlook.Recipient
    Dim objOlAppRecip2 As Outlook.Recipient
    Dim objOlAppAnexo As Outlook.Attachment
    
    'Criar objeto do outlook
    Set objOlAppApp = CreateObject("Outlook.Application")
    Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)

    With objOlAppMsg
        'Email do destinatário
        Set objOlAppRecip = .Recipients.Add("[email protected]")
        objOlAppRecip.Type = olTo
        Set objOlAppRecip2 = .Recipients.Add(lEmail)
        objOlAppRecip.Type = olCC
        
        'Grau de importância do email
        .Importance = olImportanceHigh
        'Cabeçalho do email
        .Subject = "[Confidencial] Manual XXXX - " & lAR
        'Texto do email
        
        
        '        .HTMLBody = "<b>À</b> <br>" _
        & "<b>XXXX  " & lTarefa & "</b>" & "<br>" & "<br>" _
        & "<b>A/C.: Sr(a)." & lPessoa & "</b>" & "<br>" _
        & lCopy & "<br>" & "<br>" _
        & "Assunto: XXXXX" & "<br>" & "<br>" _
        & "<b>XXXXXX</b>, inscrita no CNPJ nº. 0XXX, sediada na XXX, nº 9SS4, 12º andar, São Paulo/SP, CEP 000003, expõe o quanto segue anexo." & "<br>" & "<br>" & "<br>" & "<br>" _
        & "Atenciosamente," & "<br>" _
        & "Departamento XXXXs"
        '.Attachments.Add "CAMINHO DIRETÓRIO"
        '.Display
   

    'Liberar variáveis
    Set objOlAppApp = Nothing
    Set objOlAppMsg = Nothing
    Set objOlAppAnexo = Nothing
    Set objOlAppRecip = Nothing
    Set obgOlAppRecip2 = Nothing
End Sub


'Enviar emails das pendências
Sub lsEnviarAtrasos()
    Dim iTotalLinhas    As Long
    Dim i               As Long
    Dim lHoje           As Date

    Worksheets("5W2H").Select
    Cells(2, 1).Select

    iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    i = 2
    
    While i < iTotalLinhas
        If Cells(i, 6).Value >= Range("CP2").Value Then
            Enviar_email Cells(i, 1).Value, Cells(i, 2).Value, Cells(i, 3).Value, Cells(i, 4).Value, Cells(i, 5).Value, Cells(i, 6).Value, Cells(i, 7).Value
        End If
        i = i + 1
    Wend
End Sub

'Enviar emails e fechar aplicação
Sub lsValidaEnvio()

     If MsgBox("Deseja verificar as pendências e enviar por email?", vbYesNo, "Confirmar envio de email") = vbYes Then
        lsEnviarAtrasos
        
    End If
End Sub

 

[Basole]

Para entender melhor a sua demanda, envie o arquivo ou um modelo bem próximo do original, com alguns dados fictícios

 

[Vitor Hugo Ataide Almeida]

@Basole Segue planilha, no caso, quando os endereços de email se repetirem eu gostaria que ele enviasse apenas um, mas com todos os dados das respectivas linhas que contém esse email.

 

Atualmente ele envia 1 email para cada linha.

Email Automatc.xlsx