Wanted to filter the data by column B (Emailid) and send email individually

[guptapradeep433]

Hi.. I have executed this code as its working as per my requirement but issue with ".To " Its selecting only one email id from Range "B2" and applying to all the record whereas in each record their own email id should come. Please help with this

Sub mailstrangejosh()
    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
    Dim outlookmailitem As Object
    Dim edress As String
    
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A1:X" & lastRow).Value
                    
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
    
        For j = 2 To lastRow
            If Not .exists(v(j, 2)) Then
                .Add v(j, 2), Nothing
                
                strbody = "Hello , " & v(j, 20) & "<br></br>" & vbNewLine & vbNewLine & _
               "<br> Please find the below banker  feedback details. Thank you" & "<br/><br>"
                
                With ActiveSheet
                    .Range("A1").AutoFilter 2, v(j, 2)
                    Set myRng = .Range("A1:I" & lastRow).SpecialCells(xlCellTypeVisible)
                    
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        '.To = v(j, 20)
                        .To = Range("B2")
                 
                        .Subject = v(j, 10) & "Banker Feedback"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                         .display        'to show
                         '.Send 'to send
                    End With
                End With
            End If
        Next j
      
    End With
    
    Range("A1").AutoFilter
    
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
        
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
            
    TempWB.Close savechanges:=False
    
    Kill TempFile
          
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
  
End Function

 

[HaHoBe]

Hi guptapradeep433,

the constant range

                        .To = Range("B2")

should be substituted by

                        .To = v(j, 2)

HTH,
Holger

 

[guptapradeep433]

Hi guptapradeep433,

the constant range

                        .To = Range("B2")

should be substituted by

                        .To = v(j, 2)

HTH,
Holger

Thank you Sir... please help me with 2 things
1. How to add users' signatures by default in outlook after the body text
2. How to make outlook body text to Calibri Font + 11 pt.

 

[HaHoBe]

Hi guptapradeep433,

these question seem to have nothing to do with the original request.

Sub mailstrangejosh_mod()
' https://www.mrexcel.com/board/threads/wanted-to-filter-the-data-by-column-b-emailid-and-send-email-individually.1226961/
Dim OutApp As Object, OutMail As Object
Dim myRng As Range, v As Variant
Dim j As Long, lastRow As Long
Dim strbody As String

Application.ScreenUpdating = False

lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
v = Range("A1:X" & lastRow).Value

Set OutApp = CreateObject("Outlook.Application")
With CreateObject("scripting.dictionary")
  For j = 2 To lastRow
    If Not .exists(v(j, 2)) Then
      .Add v(j, 2), Nothing
            
      With ActiveSheet
        .Range("A1").AutoFilter 2, v(j, 2)
        Set myRng = .Range("A1:I" & lastRow).SpecialCells(xlCellTypeVisible)
      End With
       
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
        .Display
        strbody = "Hello , " & v(j, 20) & "<br></br>" & vbNewLine & vbNewLine & _
          "<br> Please find the below banker  feedback details. Thank you" & "<br/><br>"
        .To = v(j, 2)

        .Subject = v(j, 10) & " Banker Feedback"
        .HtmlBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & strbody & .HtmlBody & "<br>" & RangetoHTML(myRng)
'        .Send 'to send
      End With
    End If
  Next j
End With

Range("A1").AutoFilter

Application.ScreenUpdating = True
End Sub

No changes for RangeToHTML (should be the code posted on the site of Ron de Bruin).

Ciao,
Holger

 

[guptapradeep433]

Hi guptapradeep433,

these question seem to have nothing to do with the original request.

Sub mailstrangejosh_mod()
' https://www.mrexcel.com/board/threads/wanted-to-filter-the-data-by-column-b-emailid-and-send-email-individually.1226961/
Dim OutApp As Object, OutMail As Object
Dim myRng As Range, v As Variant
Dim j As Long, lastRow As Long
Dim strbody As String

Application.ScreenUpdating = False

lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
v = Range("A1:X" & lastRow).Value

Set OutApp = CreateObject("Outlook.Application")
With CreateObject("scripting.dictionary")
  For j = 2 To lastRow
    If Not .exists(v(j, 2)) Then
      .Add v(j, 2), Nothing
           
      With ActiveSheet
        .Range("A1").AutoFilter 2, v(j, 2)
        Set myRng = .Range("A1:I" & lastRow).SpecialCells(xlCellTypeVisible)
      End With
      
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
        .Display
        strbody = "Hello , " & v(j, 20) & "<br></br>" & vbNewLine & vbNewLine & _
          "<br> Please find the below banker  feedback details. Thank you" & "<br/><br>"
        .To = v(j, 2)

        .Subject = v(j, 10) & " Banker Feedback"
        .HtmlBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & strbody & .HtmlBody & "<br>" & RangetoHTML(myRng)
'        .Send 'to send
      End With
    End If
  Next j
End With

Range("A1").AutoFilter

Application.ScreenUpdating = True
End Sub

No changes for RangeToHTML (should be the code posted on the site of Ron de Bruin).

Ciao,
Holger

Thank you Holger.

Please help me with 2 more things

1. Adding outlook signature automatically
2. Add an extra row which for each individuals which will COUNT the no. of rows

 

[HaHoBe]

Hi guptapradeep433,

has the original request been solved? If so please don't use this thread to add new and/or different requests. And don't ask for the same request in different threads.

Holger