Adilson Lolatto

Eu tenho uma macro para enviar e-mails para diferentes destinatários, mas agora quero adicionar anexos. O problema é que os caminhos dos anexos estão em uma tabela de Excel e variam de acordo com o cliente. Ex: Cliente A tem 3 linhas na tabela, cada uma com um anexo; cliente B tem 5 linhas, etc. Alguém sabe como vlookupear os caminhos dos arquivos e adicionar os anexos, de acordo com o cliente? Segue meu código que está funcionando para enviar sem anexos: Sub Controle_de_orçamentos() response = MsgBox("Deseja enviar as cobranças?", vbYesNo) If response = vbNo Then MsgBox ("Então tchau") Exit Sub End If Dim OutApp As Object Dim OutMail As Object Dim rng As Range Dim Ash As Worksheet Dim Cws As Worksheet Dim Rcount As Long Dim Rnum As Long Dim FilterRange As Range Dim FieldNum As Integer Dim mailAddress As String On Error GoTo cleanup Set OutApp = CreateObject("Outlook.Application") With Application .EnableEvents = False .ScreenUpdating = False End With 'Set filter sheet, you can also use Sheets("MySheet") Set Ash = ActiveSheet 'Set filter range and filter column (Column with names) Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count) FieldNum = 1 'Filter column = A because the filter range start in A 'Add a worksheet for the unique list and copy the unique list in A1 Set Cws = Worksheets.Add FilterRange.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=Cws.Range("A1"), _ CriteriaRange:="", Unique:=True 'Count of the unique values + the header cell Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1)) 'If there are unique values start the loop If Rcount >= 2 Then For Rnum = 2 To Rcount 'Filter the FilterRange on the FieldNum column FilterRange.AutoFilter Field:=FieldNum, _ Criteria1:=Cws.Cells(Rnum, 1).Value 'Look for the mail address in the MailInfo worksheet mailAddress = "" On Error Resume Next mailAddress = Application.WorksheetFunction. _ VLookup(Cws.Cells(Rnum, 1).Value, _ Worksheets("Mailinfo").Range("A1:B" & _ Worksheets("Mailinfo").Rows.Count), 2, False) On Error GoTo 0 If mailAddress <> "" Then With Ash.AutoFilter.Range On Error Resume Next Set rng = .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = mailAddress .Subject = "Orçamentos aguardando aprovação - Indi Empilhadeiras" .HTMLBody = "Prezados(as), boa tarde!<br>" & _ "Poderiam, por gentileza, informar se os orçamentos abaixo estão aprovados?" & RangetoHTML(rng) & _ "<br>Obrigado!<br>" & _ "namoenome nomenome<br>" & _ "(xx) xxxx-xxxx" .ReadAttachments .Display 'Or use Send .Send End With On Error GoTo 0 Set OutMail = Nothing End If 'Close AutoFilter Ash.AutoFilterMode = False Next Rnum End If cleanup: Set OutApp = Nothing Application.DisplayAlerts = False Cws.Delete Application.DisplayAlerts = True With Application .EnableEvents = True .ScreenUpdating = True End With End Sub