Hỗ trợ: gửi email bằng VBA lọc vùng dữ liệu

[haianh89]

Nhờ các Anh/Chị hỗ trợ,

Hiện tại em thấy được đoạn code của bác HLMT đã sửa được nội dung phù hợp.
Phát sinh trường hợp mỗi lần em muốn test nội dung chương trình chậy hết toàn bộ
Do em mới tập tành chưa biết nhiều nhờ Anh/Chị hỗ trợ vùng lựa chọn ví dụng như vùng lựa chọn từ ô H3-H4 sheet Mailinfo.
Chi tiết theo file đính kèm.

Sub GuiMail()
    Dim OutApp As Object, OutMail As Object
    Dim WB As Workbook, Ash As Worksheet, mailAddress As String, mailcc As String, i As Integer, ir As Integer, ip As Integer
    Dim Rcount As Long, FileName As String, Rnum As Long, strHeader As String, strRow As String
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    Set Ash = Sheet1
    Rcount = Application.WorksheetFunction.CountA(Ash.Columns(1))
    For i = 1 To 11
          strHeader = strHeader & " " & "<th>" & Ash.Cells(1, i) & "</th>"
    Next
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount
            strRow = ""
            For ir = 1 To 11
                strRow = strRow & " " & "<td>" & Ash.Cells(Rnum, ir) & "</td>"
                Sheets("Form").Cells(8, ir) = Ash.Cells(Rnum, ir)
            Next
            mailAddress = ""
            On Error Resume Next
            mailAddress = Application.WorksheetFunction. _
                          VLookup(Ash.Cells(Rnum, 1).Value, _
                                Worksheets("Mailinfo").Range("A1:C" & _
                                Worksheets("Mailinfo").Rows.Count), 3, False)
            mailcc = Application.WorksheetFunction. _
                          VLookup(Ash.Cells(Rnum, 1).Value, _
                                Worksheets("Mailinfo").Range("A1:D" & _
                                Worksheets("Mailinfo").Rows.Count), 4, False)
                                
            Sheets.[3].Copy
            Set WB = ActiveWorkbook
            FileName = Ash.Cells(Rnum, 1) & ".xls"
            Kill "D:\" & FileName
            On Error GoTo 0
            WB.SaveAs FileName:="D:\" & FileName
            If mailAddress <> "" Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail

                    .To = mailAddress
                    .Subject = "Chi tiet bang luong: " & Ash.Range("B" & Rnum) _
                                & " (Voi he so chuc danh la " & Ash.Range("C" & Rnum) & ")"
                    '.Attachments.Add WB.FullName           'dinh kem file sheet From
                    .HTMLBody = "<B>Dear " & Ash.Range("B" & Rnum) & ",</B><BR>" & _
                           "Xin vui long xem chi tiet bang luong nhu ben duoi:<BR><BR>" & _
                                "<table border=1><tr>" & _
                                strHeader & _
                                "</tr><tr>" & _
                                strRow & _
                                "</tr>" & _
                                "</table>" & _
                                "<BR>" & _
                            "Neu thay co gi thac mac xin vui long phan hoi som.<BR>" & _
                              "<B>Xin Cam on,</B>" & _
                            "<BR>" & _
                            "<B>HLMT<B>" & _
                            "<BR>" & _
                            Ash.Range("O9")
                    .Display  'Or use Send
                End With
                On Error GoTo 0
                Set OutMail = Nothing
            End If
            WB.ChangeFileAccess Mode:=xlReadOnly
            Kill WB.FullName
            WB.Close SaveChanges:=False
        Next Rnum
    End If
    
MsgBox "Da tao xong email gui", vbInformation
'ThisWorkbook.Close (False)
cleanup:
    Set OutApp = Nothing: Set OutMail = Nothing

End Sub

Cảm ơn các Anh/Chị nhiều.