[HỎI-ĐÁP]Cách để gộp chung người nhận trong 1 mail outlook duy nhất

Liên hệ QC

hoasuajp

Thành viên mới
Tham gia
7/4/22
Bài viết
43
Được thích
3
Giới tính
Nữ
Chào các anh chị GPE.
Em có đoạn code sau:
Mã:
 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.
 
Chào các anh chị GPE.
Em có đoạn code sau:
Mã:
 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.
Bạn tạo 1 biến string rồi chạy vòng lặp for duyệt qua tất cả các dòng đó gộp lại với nhau là được.
 
Upvote 0
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
 
Upvote 0
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 đỡ.
 
Upvote 0
Xóa dòng

On Error Resume Next

.
.
.

sẽ tìm thấy lý do.
 
Upvote 0
Mệt quá!

1652947046057.png

PHP:
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
 

File đính kèm

  • 1652947054740.png
    1652947054740.png
    20.4 KB · Đọc: 4
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
Xin lỗi anh @befaint vì câu hỏi không rõ ràng khiến anh không vui ạ,em sẽ rút kinh nghiệm lần sau hỏi đúng cái cần hỏi ạ (@$%@
Bài đã được tự động gộ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
Cám ơn anh ạ, code đã ok rồi ạ, chỉ tại mù mờ mà đặt câu hỏi khù khờ. cám ơn anh đã giải thích rõ ràng dễ hiểu đến vậy,tuyệt vời ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom