Email each team member while skipping those with no existing worksheet

Question

I'm trying to email our team their weekly progress reports from a workbook.
Each team member's progress report is in its own sheet.
Those who have not yet made any progress do not have a sheet.

The code below is great for when everybody on the contact list has a corresponding report/sheet.
I need to edit the code to email only those who have a sheet listed next to their name.

I'm also trying to get the normal email signature of the person who sends this report to appear in the email.

My CONTACTS sheet has email addresses in column A and sheet names in column 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 = "john.doe@doe.com"
                    .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