Em có tìm được đoạn code gửi tính lương. 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 ạ
Và Code em liệt kê các công việc quá hạn và hết hạn
Link down file (do diễn đàn không cho Att) :
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
Mã:
Sub Run_BB_HetHan_SapHet()
Dim i, k, kk, ar, Arr_SapHetHan, Arr_HetHan
Dim Nguon, Dong
Dim LastRow_HH, LastRow_SHH
With Sheets("Data")
Dong = .Range("B3").End(xlDown).Row
Nguon = .Range("A3", "O" & Dong) 'Cot cuoi cung tai Sheet Input_TB
Dong = UBound(Nguon)
End With
ReDim Arr_SapHetHan(1 To Dong, 1 To 12)
ReDim Arr_HetHan(1 To Dong, 1 To 12)
'Chay kiem tra dau viec sap het han
For i = 1 To Dong
If Nguon(i, 7) >= Date And Nguon(i, 7) - Date < Sheet5.Range("NgayNhac").Value And Nguon(i, 12) <> "Finish" Then 'Ktra lay nhung vat tu DVSD
k = k + 1
Arr_SapHetHan(k, 1) = k
Arr_SapHetHan(k, 2) = Nguon(i, 2)
Arr_SapHetHan(k, 3) = Nguon(i, 3)
Arr_SapHetHan(k, 4) = Nguon(i, 4) 'Ten VTTB
Arr_SapHetHan(k, 5) = Nguon(i, 5) 'Ma VT
Arr_SapHetHan(k, 6) = Nguon(i, 6) 'So luong nghiem thu
Arr_SapHetHan(k, 7) = Nguon(i, 7)
Arr_SapHetHan(k, 8) = Nguon(i, 7) - Date
'Don gia
Arr_SapHetHan(k, 9) = Nguon(i, 8) 'Don gia
Arr_SapHetHan(k, 10) = Nguon(i, 9) 'Don gia
Arr_SapHetHan(k, 11) = Nguon(i, 10) 'Don gia
End If
Next i
'Chay kiem tra dau viec het han
For i = 1 To Dong
If Nguon(i, 4) <> "" And Nguon(i, 7) < Date And Nguon(i, 7) - Date < 0 And Nguon(i, 12) = "" Then 'Ktra lay nhung vat tu DVSD
kk = kk + 1
Arr_HetHan(kk, 1) = kk
Arr_HetHan(kk, 2) = Nguon(i, 2)
Arr_HetHan(kk, 3) = Nguon(i, 3)
Arr_HetHan(kk, 4) = Nguon(i, 4) 'Ten VTTB
Arr_HetHan(kk, 5) = Nguon(i, 5) 'Ma VT
Arr_HetHan(kk, 6) = Nguon(i, 6) 'So luong nghiem thu
Arr_HetHan(kk, 7) = Nguon(i, 7)
Arr_HetHan(kk, 8) = Nguon(i, 7) - Date
'Don gia
Arr_HetHan(kk, 9) = Nguon(i, 8) 'Don gia
Arr_HetHan(kk, 10) = Nguon(i, 9) 'Don gia
Arr_HetHan(kk, 11) = Nguon(i, 10) 'Don gia
End If
Next i
Sheets("Baocao").Select
With Sheets("Baocao")
.Range("A6").Resize(kk, 12).Value = Arr_HetHan
LastRow_SHH = Sheets("Baocao").Cells(Rows.Count, "D").End(xlUp).Row
.Range("B" & LastRow_SHH + 1).Formula = "CONG VIEC SAP HET HAN"
If k Then
.Range("A" & LastRow_SHH + 2).Resize(k, 12).Value = Arr_SapHetHan
End If
' .Range("C3:F" & 12 + k - 1).WrapText = 1
' .Range("C3:F" & 12 + k - 1).HorizontalAlignment = xlJustify
' .Range("A12:M" & 12 + k - 1).Font.Bold = False
.Range("A4").Resize(kk, 12).Borders.LineStyle = 1
' .Range("H12:J" & 12 + k + 1).NumberFormat = "#,##0.00"
' .Range("J" & 12 + k + 1).Formula = "=SUBTOTAL(9,J12:J" & 12 + k & ")"
'Can chinh
' .Rows("12:" & LastRow - 1 & "").RowHeight = 35
' .Rows("" & LastRow & ":" & LastRow + 4 & "").RowHeight = 23
.PageSetup.PrintArea = "$A$1:$L" & LastRow_SHH + 4 & ""
End With
End Sub
Bạn cần đăng nhập để thấy link