quyenpv
Thu nhặt kiến thức
- Tham gia
- 5/1/13
- Bài viết
- 719
- Được thích
- 97
- Giới tính
- Nam
- Nghề nghiệp
- Decode cuộc đời!
Em có tìm được đoạn code gửi tính lương của anh Hai Lúa Miền Tây. Tuy nhiên khi sửa điều kiện gửi ngày phải hoàn thành so với ngày hiện tại không chạy, mong các anh chỉ giúp
Em có Sheet Data và Sheet Noidung như trong file đính kèm
Mục đích cảnh báo tiến độ công việc chậm và sắp hết hạn cần phải hoàn thành. Code sẽ lấy thời gian hoàn thành tại cột G trong Sheet Data so sánh với ngày hiện tại đưa vào Body email như trong Sheet Noidung và đính kèm file att
Mong các anh chỉ giúp ạ
Em có Sheet Data và Sheet Noidung như trong file đính kèm
Mục đích cảnh báo tiến độ công việc chậm và sắp hết hạn cần phải hoàn thành. Code sẽ lấy thời gian hoàn thành tại cột G trong Sheet Data so sánh với ngày hiện tại đưa vào Body email như trong Sheet Noidung và đính kèm file att
Mong các anh chỉ giúp ạ
Mã:
Sub GuiMail()
Dim OutApp As Object, OutMail As Object
Dim Ash As Worksheet, Cws As Worksheet
Dim Rcount As Long, Rnum As Long
Dim FilterRange As Range, FieldNum As Integer, mailAddress As String
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Ash = ActiveSheet
Ash.Cells.EntireColumn.AutoFit
Set FilterRange = Ash.Range("A2:O" & Ash.Rows.Count)
FieldNum = 7 'Thoi gian hoan thanh
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("G2"), _
CriteriaRange:="", Unique:=True
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
If Rcount >= 2 Then
For Rnum = 2 To Rcount
FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:C" & _
Worksheets("Mailinfo").Rows.Count), 3, 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
.BodyFormat = olFormatHTML
.To = mailAddress
.Subject = "Chi tiet bang luong: " & Ash.Range("B" & Rnum) _
& " (Voi he so chuc danh la " & Ash.Range("C" & Rnum) & ")"
.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>" & _
"<th>H" & ChrW(7885) & " tên</th>" & _
"<th>H" & ChrW(7879) & " s" & ChrW(7889) & " ch" & ChrW(7913) & "c danh</th>" & _
"<th>S" & ChrW(7889) & " ngày công</th>" & _
"<th>L" & ChrW(432) & ChrW(417) & "ng CD</th>" & _
"<th>Ph" & ChrW(7909) & " c" & ChrW(7845) & "p " & ChrW(273) & "i" & ChrW(7879) & "n thoai</th>" & _
"<th>Ph" & ChrW(7909) & " c" & ChrW(7845) & "p " & ChrW(273) & "oàn th" & ChrW(7875) & "</th>" & _
"<th>Tr" & ChrW(7915) & " BHXH,BHTY</th>" & _
"<th>L" & ChrW(432) & ChrW(417) & "ng CK</th></tr><tr>" & _
"<td>" & Ash.Range("B" & Rnum) & "</td>" & _
"<td>" & Ash.Range("C" & Rnum) & "</td>" & _
"<td>" & Ash.Range("D" & Rnum) & "</td>" & _
"<td>" & Ash.Range("E" & Rnum) & "</td>" & _
"<td>" & Ash.Range("F" & Rnum) & "</td>" & _
"<td>" & Ash.Range("G" & Rnum) & "</td>" & _
"<td>" & Ash.Range("H" & Rnum) & "</td>" & _
"<td>" & Ash.Range("I" & Rnum) & "</td></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
Ash.AutoFilterMode = False
Next Rnum
End If
MsgBox "Da tao xong email gui", vbInformation
ThisWorkbook.Close (False)
cleanup:
Set OutApp = Nothing: Set OutMail = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
