Sub Button4_Click()
Dim ArrData, i As Long, FName As String
Dim OutApp As Object
Dim OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String
Dim sPath As String
Dim j As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
printFrom = Sheets("Sheet3").Range("I8")
printTo = Sheets("Sheet3").Range("I9")
Set OutApp = CreateObject("Outlook.Application")
For j = printFrom To printTo
Sheets("Sheet3").Range("I5") = j
sPath = Application.ActiveWorkbook.Path
'ArrData = Sheet3.Range(Sheets("Sheet3").Range("I14"), Sheet2.Cells(&H100000, 2).End(xlUp)).Value
ArrData = Sheet2.Range(Sheet2.Cells(2, 15), Sheet2.Cells(&H100000, 2).End(xlUp)).Value
'Sheets("Sheet3").Range("A1:D33").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
sFile = ThisWorkbook.Path & "\Phieuluong" & Format(Now, "yyyy-mm")
Const DeleteReadOnly = True
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(sFile) Then
fso.DeleteFolder sFile, DeleteReadOnly
fso.CreateFolder (sFile)
End If
If Not fso.FolderExists(sFile) Then
fso.CreateFolder (sFile)
End If
For i = 1 To UBound(ArrData, 1)
Sheet3.Cells(11, 2).Value = ArrData(i, 1)
Sheets("Sheet3").Range("A2:D33").Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
ActiveWorkbook.SaveAs sFile & "\" & ArrData(i, 1) & ".xlsx", , ArrData(i, 73)
ActiveWorkbook.Close False
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheets("Sheet3").Range("B12")
.CC = ""
.BCC = ""
.Subject = Sheets("Sheet3").Range("B9")
.HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of December 2019. <BR>" & _
"<BR>Should you have any questions, do not hestitate to contact us." & _
"<BR><BR>Thanks & regards</B><BR>" & _
"</B>"
.Attachments.Add (sFile)
.Send
End With
Set OutMail = Nothing
Next j
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox "Success"
End Sub
. Hay do em dùng Office bản 64 bit? Ai cũng lỗi thì dễ tìm được câu trả lời. Sợ nhất khác biệt.
