Giúp đỡ viết code VBA gửi email hàng loạt với nội dung và file đính kèm khác nhau (1 người xem)

[sytaichinh]

Xin chào anh chị,
Nhờ anh chị xem giúp mình đoạn code này có thể sửa để thêm chức gửi email với nội dung khác nhau được không, Minh xin cám ơn:

Sub Send_Mail()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String
Dim cont As String
Dim ct1 As String, ct2 As String, ct3 As String
Dim i As Integer, n As Integer

ct1 = Trim(Sheets("Set_up").Range("F12").Value)
ct2 = Trim(Sheets("Set_up").Range("F13").Value)
ct3 = Trim(Sheets("Set_up").Range("F14").Value)

cont = ct1 & ct2 & ct3

Sheets("Set_up").Select
Range("I8").Select
Range(Selection, Selection.End(xlDown)).Select
n = Selection.Count

Sheets("Set_up").Select
Range("Group").Select

For i = 1 To n
Group = Trim(Sheets("Set_up").Cells(i + 7, 9).Value)
Sheets("Set_up").Range("Group").Value = Group

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.Display
End With
Signature = OutMail.htmlBody

On Error Resume Next

With OutMail
.To = Trim(Sheets("Set_up").Range("Recipient").Value)
.cc = Trim(Sheets("Set_up").Range("Cc").Value)
.Subject = Trim(Sheets("Set_up").Range("Subject").Value)
.htmlBody = cont & Signature
.Attachments.Add Trim(Sheets("Set_up").Range("PathFile").Value)
'.Display
.Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Next i
MsgBox ("Send Mail Completed!")
End Sub

 

[dovanhoc84]

Tôi thấy cái này chạy bt mà nhỉ?
Nếu muốn nội dung khác nhau thì điền nội dung khác nhau ở cột M, file đính kèm khác nhau thì điềm cột L là ok mà nhỉ?

 

[sytaichinh]

Không được bạn ah. Phần nội dung nó khog chạy theo như minh nghĩ. Nếu bạn rành về code vba thì xem lại giúp mình nhé. Thanks