nowrow = 12
Do While True
nowrow = nowrow + 1
'sua hang trong
If ws.Cells(7, nowrow) = "" Then Exit Do
'‘ÎÛs‚É’l‚ª[chua]“ü—Í‚³‚ê‚Ä‚¢‚ê‚ÎAƒ[ƒ‹‰º‘‚«‚đ́¬‚·‚é
If ws.Cells(8, nowrow) = "Chua" Then
Set objmail = objoutlook.CreateItem(0)
With objmail
.subject = ThisWorkbook.Sheets("lan2").Range("B2").Value
'ten nguoi nhan
.To = ws.Cells(7, nowrow).Value
'noi dung
.Body = ws.Cells(6, nowrow).Value & vbCrLf & _
ThisWorkbook.Sheets("lan2").Range("C2").Value & vbCrLf & vbCrLf
.Display
End With
End If
Loop
trường hợp muốn gộp danh sách người nhận thì .To mình chỉnh sửa thế nào cho hợp lý ạ, mong các anh chị giải đáp.
nowrow = 12
Do While True
nowrow = nowrow + 1
'sua hang trong
If ws.Cells(7, nowrow) = "" Then Exit Do
'‘ÎÛs‚É’l‚ª[chua]“ü—Í‚³‚ê‚Ä‚¢‚ê‚ÎAƒ[ƒ‹‰º‘‚«‚đ́¬‚·‚é
If ws.Cells(8, nowrow) = "Chua" Then
Set objmail = objoutlook.CreateItem(0)
With objmail
.subject = ThisWorkbook.Sheets("lan2").Range("B2").Value
'ten nguoi nhan
.To = ws.Cells(7, nowrow).Value
'noi dung
.Body = ws.Cells(6, nowrow).Value & vbCrLf & _
ThisWorkbook.Sheets("lan2").Range("C2").Value & vbCrLf & vbCrLf
.Display
End With
End If
Loop
trường hợp muốn gộp danh sách người nhận thì .To mình chỉnh sửa thế nào cho hợp lý ạ, mong các anh chị giải đáp.
Em đã làm được rồi ạ, mặc dù mới học nhiều thứ chưa biết nhưng sau những lần thất bại thì em cũng đã làm được, mặc dù không được perfect cho lắm.
Em xin chia sẻ code cho ai cần ạ.
Mã:
Sub guimaillan2()
'updateby Extendoffice
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr, timeset, getname As String
Dim ws As Worksheet
timeset = ThisWorkbook.Sheets(4).Range("C7").Value
Set ws = Workbooks("file.xlsx").Worksheets("notcheck")
getname = ws.Range("AQ7").Value
On Error Resume Next
Set xRg = ws.Range("A7:AP7")
If xRg Is Nothing Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In xRg
'If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
' End If
End If
Next
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.subject = ThisWorkbook.Sheets("lan2").Range("B2").Value & "(" & timeset & ")"
.To = xEmailAddr
.BodyFormat = 2
.HTMLBody = "" _
.Display
End With
End Sub
Có anh/chị nào hỗ trợ em xử lý ngoại lệ trường hợp trên được không ạ, e đã thử If xRg Is Nothing Then Exit Sub nhưng vẫn hiện lên màn hình gửi mail. Nếu range không có giá trị thì thoát chương trình mà ko hiện hộp thoại mail outlook thì làm thế nào hợp lý ạ. Mong anh chị giúp đỡ.
private function getListEmailTo(byval oRangeMail as range) as string
const sDelim = "@"
Dim varItem as variant, strEmail as string
Dim listEmails as variant
if oRangeMail.count = 1 then
if vba.instr(1, oRangeMail.value, sDelim )>0 then
getListEmailTo = oRangeMail.value
exit function
end if
end if
''
redim listEmails(1 to oRangeMail.count)
for each varItem in oRangeMail.value2
strEmail = vba.cstr(varItem)
if vba.instr(1, strEmail, sDelim)>0 then
i = i + 1
listEmails(i)=strEmail
end if
next varItem
if i>0 then
redim preserve listEmails(1 to i)
getListEmailTo = vba.join(listEmails, ";")
end if
End function
' ap dung '
Dim listEmailsTo as string
Set xRg = ws.Range("A7:AP7")
listEmailsTo = getListEmailTo(xRg )
if vba.len(listEmailsTo ) = 0 then Exit sub
Set xOTApp = CreateObject("Outlook.Application")
Set xMItem = xOTApp.CreateItem(0)
With xMItem
'...'
End With
Có anh/chị nào hỗ trợ em xử lý ngoại lệ trường hợp trên được không ạ, e đã thử If xRg Is Nothing Then Exit Sub nhưng vẫn hiện lên màn hình gửi mail. Nếu range không có giá trị thì thoát chương trình mà ko hiện hộp thoại mail outlook thì làm thế nào hợp lý ạ. Mong anh chị giúp đỡ.
Bạn chịu khó đọc. Nếu tôi chỉ tung code thì đơn giản cho tôi và đỡ mất nhiều thời gian, nhưng bạn sẽ không hiểu cái sai của bạn nằm ở đâu.
Bạn có
Mã:
Set xRg = ws.Range("A7:AP7")
Vậy thì xRg MUÔN ĐỜI không là NOTHING. Nó luôn là vùng có 42 ô - từ A7 đến AP7, cho dù vùng đó chứa ông trời hay chả chứa gì. Một dãy 42 nhà trống thì vẫn là một dãy nhà.
Ý bạn xRg = Nothing có nghĩa là gì? Lần sau thay vì "e đã thử If xRg Is Nothing Then Exit Sub" thì nên viết vd. "Em muốn khi tất cả các ô trong vùng xRg đều trống thì Exit Sub". Bạn từng than là mặt buồn rười rượi nhưng bạn không tự hỏi, tại sao đôi lúc người khác không trả lời. Do mình không biết hỏi thôi.
xRg = Nothing và xRg = "hoàn toàn rỗng" là 2 thứ khác nhau. Như trên tôi đã viết, xRg được xác định như thế thì MUÔN ĐỜI không Nothing. Tức MUÔN ĐỜI không thực hiện Exit Sub.
Có thể trước hết kiểm tra xem xRg có là toàn ô rỗng không. Nếu đúng thì Exit Sub. Nhưng đằng nào cũng phải sửa code để phục vụ trường hợp tổng quát: khi một số ô rỗng, một số ô có giá trị. Đằng nào cũng sửa đoạn code gộp chuỗi nên khỏi cần kiểm tra liệu xRg có là toàn ô rỗng không trước đó. Đơn giản là sau khi có xEmailAddr thì kiểm tra nó có rỗng không, nếu rỗng thì Exit sub.
Tôi sửa trong notepad nên có thể sơ ý, chỉ để tham khảo thôi. Tôi không tối ưu code, tôi không viết code khác. Tôi chỉ sửa những cái cần thiết cho đúng ý bạn. Học khắc phục lỗi trên chính code của mình mới là học, và nhớ lâu.
Mã:
Sub guimaillan2()
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr, timeset, getname As String
Dim ws As Worksheet
timeset = ThisWorkbook.Sheets(4).Range("C7").Value
Set ws = Workbooks("file.xlsx").Worksheets("notcheck")
getname = ws.Range("AQ7").Value
' On Error Resume Next
Set xRg = ws.Range("A7:AP7")
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
If xEmailAddr = "" Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.Subject = ThisWorkbook.Sheets("lan2").Range("B2").Value & "(" & timeset & ")"
.To = xEmailAddr
.BodyFormat = 2
.HTMLBody = "" _
.Display
End With
End Sub
Bạn chịu khó đọc. Nếu tôi chỉ tung code thì đơn giản cho tôi và đỡ mất nhiều thời gian, nhưng bạn sẽ không hiểu cái sai của bạn nằm ở đâu.
Bạn có
Mã:
Set xRg = ws.Range("A7:AP7")
Vậy thì xRg MUÔN ĐỜI không là NOTHING. Nó luôn là vùng có 42 ô - từ A7 đến AP7, cho dù vùng đó chứa ông trời hay chả chứa gì. Một dãy 42 nhà trống thì vẫn là một dãy nhà.
Ý bạn xRg = Nothing có nghĩa là gì? Lần sau thay vì "e đã thử If xRg Is Nothing Then Exit Sub" thì nên viết vd. "Em muốn khi tất cả các ô trong vùng xRg đều trống thì Exit Sub". Bạn từng than là mặt buồn rười rượi nhưng bạn không tự hỏi, tại sao đôi lúc người khác không trả lời. Do mình không biết hỏi thôi.
xRg = Nothing và xRg = "hoàn toàn rỗng" là 2 thứ khác nhau. Như trên tôi đã viết, xRg được xác định như thế thì MUÔN ĐỜI không Nothing. Tức MUÔN ĐỜI không thực hiện Exit Sub.
Có thể trước hết kiểm tra xem xRg có là toàn ô rỗng không. Nếu đúng thì Exit Sub. Nhưng đằng nào cũng phải sửa code để phục vụ trường hợp tổng quát: khi một số ô rỗng, một số ô có giá trị. Đằng nào cũng sửa đoạn code gộp chuỗi nên khỏi cần kiểm tra liệu xRg có là toàn ô rỗng không trước đó. Đơn giản là sau khi có xEmailAddr thì kiểm tra nó có rỗng không, nếu rỗng thì Exit sub.
Tôi sửa trong notepad nên có thể sơ ý, chỉ để tham khảo thôi. Tôi không tối ưu code, tôi không viết code khác. Tôi chỉ sửa những cái cần thiết cho đúng ý bạn. Học khắc phục lỗi trên chính code của mình mới là học, và nhớ lâu.
Mã:
Sub guimaillan2()
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr, timeset, getname As String
Dim ws As Worksheet
timeset = ThisWorkbook.Sheets(4).Range("C7").Value
Set ws = Workbooks("file.xlsx").Worksheets("notcheck")
getname = ws.Range("AQ7").Value
' On Error Resume Next
Set xRg = ws.Range("A7:AP7")
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
If xEmailAddr = "" Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.Subject = ThisWorkbook.Sheets("lan2").Range("B2").Value & "(" & timeset & ")"
.To = xEmailAddr
.BodyFormat = 2
.HTMLBody = "" _
.Display
End With
End Sub
