Excel MACRO ENVIAR E-MAIL - vba

[Rayane Parreira Resende]

Ei, Pessoal! 

 

Tenho código que envia e-mails, mas estou com dificuldade de atribuir valores nesta parte. 

 

Define o corpo do e-mail
     strbody = "Prezado (a) " & ws.Range("H2").Value & "," & "<br><br>" & _
     "No dia " & ws.Range("F2").Value & " você receberá os profissionais abaixo no seu time. " & "<br><br>" & _
     "Prepara-se para dar as boas-vindas e contribuir para a ambientação do novo colaborador. " & "<br><br>" & _
      & "<br><br>" & _
     strbody

 

Hoje esta com a células fixadas, mas eu precisava que percorre nas colunas do excel para ir acompanhando. 

 

Vocês conseguem me ajudar ? 

 

Segue o código. 

Sub EnviarEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim strbody As String
Dim ws As Worksheet
Dim lastrow As Long
Dim i As Long
Dim dict As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Sheets("Planilha1")
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' Última linha com dados na coluna A
Set dict = CreateObject("Scripting.Dictionary")

For i = 2 To lastrow ' Inicia do segundo registro, presumindo que a linha 1 é o cabeçalho
        dict(ws.Range("J" & i).Value) = dict(ws.Range("J" & i).Value) & ";" & ws.Range("K" & i).Value ' Adiciona o valor da coluna J ao dicionário com a cópia para a BP
    Next i

For Each key In dict ' Loop pelos valores exclusivos da coluna J
    Set OutlookMail = OutlookApp.CreateItem(0)
    OutlookMail.To = key ' Define o destinatário principal do e-mail
    OutlookMail.CC = dict(key) ' Define o destinatário em cópia do e-mail
    strbody = ""
    
    ' Cria uma tabela com o cabeçalho e os dados das colunas A a I
    strbody = "<table border='1' style='border-collapse:collapse'><tr>"
    For j = 1 To 9
        strbody = strbody & "<th>" & ws.Cells(1, j).Value & "</th>"
    Next j
    strbody = strbody & "</tr>"
    For i = 2 To lastrow ' Loop pelos dados que correspondem ao valor exclusivo da coluna J
        If ws.Range("J" & i).Value = key Then
            strbody = strbody & "<tr>"
            For j = 1 To 9
                strbody = strbody & "<td>" & ws.Cells(i, j).Value & "</td>"
            Next j
            strbody = strbody & "</tr>"
        End If
    Next i
    strbody = strbody & "</table>"
    
    ' Define o assunto do e-mail
    OutlookMail.Subject = "Novo colaborador"
      
    'Define a segunda parte do e-mail
    
    strbody1 = " <br><br> Em anexo, "
            
     ' Define o corpo do e-mail
     strbody = "Prezado (a) " & ws.Range("H2").Value & "," & "<br><br>" & _
     "No dia " & ws.Range("F2").Value & " você receberá os profissionais abaixo no seu time. " & "<br><br>" & _
     "Prepara-se para dar as boas-vindas e contribuir para a ambientação do novo colaborador. " & "<br><br>" & _
      & "<br><br>" & _
     strbody

     ' Adiciona a segunda parte do corpo do e-mail
    strbody = strbody & strbody1

          
    ' Adiciona o anexo PDF
    OutlookMail.Attachments.Add "C:\Users\loren\Desktop\guia.pdf"
    OutlookMail.HTMLBody = strbody
    

    ' Envia o e-mail
    OutlookMail.Send
    
    Set OutlookMail = Nothing ' Libera memória
Next key

Set OutlookApp = Nothing ' Libera memória
Set dict = Nothing ' Libera memória
End Sub