Gửi mail lương một cách tự động kết hợp giữa Exel và Outlook

Các chị em làm mảng nhân sự, kế toán lương điều biết việc gửi thông báo lương qua email cho từng thành viên quả là lỗi vất vả nếu đơn vị đó có đông thành viên. Hôm nay em xin chia sẻ một mẹo nhỏ giúp các bác gửi một loạt thông báo lương một cách tự động thông qua một mã Marco được lập trình sẵn. Mọi việc sẽ trở lên đơn giản hơn bao giờ hết.

Download file mẫu tại đây: https://www.fshare.vn/file/GEDCDI5Z8WM3

Code:

Option Explicit

Sub GuiMail()
    Dim OutApp As Object, OutMail As Object
    Dim WB As Workbook, Ash As Worksheet, mailAddress As String, i As Integer, ir 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 18
          strHeader = strHeader & " " & "<th>" & Ash.Cells(1, i) & "</th>"
    Next
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount
            strRow = ""
            For ir = 1 To 18
                strRow = strRow & " " & "<td>" & Ash.Cells(Rnum, ir) & "</td>"
                Sheets("Form").Cells(2, 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)
            Sheets("Form").Copy
            Set WB = ActiveWorkbook
            FileName = Ash.Cells(Rnum, 1) & ".xls"
            Kill "C:\" & FileName
            On Error GoTo 0
            WB.SaveAs FileName:="C:\" & 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
                    .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>"
                    .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

Mọi thắc mắc xin vui lòng để lại comment bên giới. Xin cảm ơn!

Aha kế toán

Gửi mail lương một cách tự động kết hợp giữa Exel và Outlook

Chia sẻ bài viết