Guru do Excel e Power BI

Sub EnviaEmails()
 Dim objOutlook As Object, objOutlookMsg As Object, email As Long, k As Long, v As Long, bod As String
  Set objOutlook = CreateObject("Outlook.Application")
  Application.ScreenUpdating = False
  Range("A2:F" & Cells(Rows.Count, 6).End(3).Row).Sort Key1:=[F1], Order1:=xlAscending
  For email = 2 To Cells(Rows.Count, 6).End(3).Row
   k = Application.CountIf([F:F], Cells(email, 6))
    Set objOutlookMsg = objOutlook.CreateItem(0)
     With objOutlookMsg
      .To = Cells(email, 6)
      .cc = ""
      .Subject = "coloque aqui o assunto"
      For v = email To email + k - 1
       bod = bod & vbLf & "NFe - " & Cells(v, 1) & "  |  CHAVE DE ACESSO - " & Cells(v, 2)
      Next v
      Cells(email, 1).Resize(k, 6).Interior.Color = vbYellow
      .Body = bod
      '.display
      .send
     End With
    email = email + k - 1: bod = ""
  Next email
End Sub