Bác HLMT ơi,
Phần CC thì em thấy rồi. Nhưng còn đoạn tách file em vẫn bị lỗi: WB.SaveAs FileName:="D:\" & FileName
View attachment 233615
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 23
strHeader = strHeader & " " & "<th>" & Ash.Cells(1, i) & "</th>"
Next
If Rcount >= 2 Then
For Rnum = 2 To Rcount
strRow = ""
For ir = 1 To 23
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)
Sheets("Form").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
.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")
.Send '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
Nhờ bác chỉ giúp em với ạ.
'''''''''
