excel - 向每个团队成员发送电子邮件，同时跳过那些没有现有工作表的成员

Question

我正在尝试通过电子邮件向我们的团队发送工作簿中的每周进度报告。
每个团队成员的进度报告都在自己的工作表中。
那些还没有取得任何进展的人没有一张纸。

当联系人列表中的每个人都有相应的报告/工作表时，下面的代码非常有用。
我需要编辑代码以仅向其姓名旁边列出工作表的人发送电子邮件。

我还试图让发送此报告的人的正常电子邮件签名出现在电子邮件中。

我的 CONTACTS 表在 A 列中有电子邮件地址，在 B 列中有工作表名称。

Public Sub MailMerge()

    Dim shname As Range
    Dim EmailAddr As String
 
    With ThisWorkbook.Sheets("CONTACTS")
        For Each shname In .Columns("B:B").SpecialCells(xlCellTypeConstants, 3)
            EmailAddr = shname.Offset(0, -1).Value
            With Sheets(shname.Value)
                .Activate
                ActiveSheet.Copy
                Filename = shname & " " & " " & "Report" & " " & Format(Date, "ddmmmyyyy") & ".xlsx"
                ActiveWorkbook.SaveAs "file location" & Filename, FileFormat:=51
                Set wb = ActiveWorkbook
                Set Mail_Object = CreateObject("Outlook.Application")
                With Mail_Object.CreateItem(o)
                    .Subject = "Weekly Report"
                    .to = EmailAddr
                    .cc = "[e-mail]"
                    .body = "Greetings," & Chr(13) & Chr(13) & "Attached is your list" & Chr(13) & "Best Regards," & Chr(13) & Chr(13) & "Sender Name" & Chr(13) & "Sender Title" & Chr(13) & "Sender Company"
                    .Attachments.Add "File Location" & Filename
                    .display '.Send change to Send if you don't need to check E-Mail before sending
                End With
            End With
            wb.ChangeFileAccess Mode:=xlReadOnly
            wb.Close SaveChanges:=False
        Next shname
    End With
End Sub

标签： excelvbaoutlook