Dim coll As Collection

Sub EmailsList()
    Dim cell As Range: Application.ScreenUpdating = False
    Set coll = New Collection
    ' перебираем все заполненные ячейки на листе в поисках адресов почты
   For Each cell In shs.UsedRange.SpecialCells(xlCellTypeConstants).Cells
        ParseAddresses cell.Text    ' проверяем очередную ячейку
   Next cell
   
    ' выводим найденные номера на второй лист
   For Each Item In coll
        shres.Range("a" & shres.Rows.Count).End(xlUp).Offset(1) = Item
    Next
End Sub

Sub cl(): shres.[a4:a65000].ClearContents: End Sub    ' очистка таблицы

Sub ParseAddresses(ByVal txt As String)
    ' ищет в тексте txt адреса электронной почты,
   ' все найденные адреса добавляются в коллекцию coll
   repl1$ = "ZZZXXXZZZ": repl2$ = "ZZZYYYZZZ": On Error Resume Next
    txt = Replace(txt, ".", repl1$): txt = Replace(txt, "-", repl2$)
    Set RegExp = CreateObject("VBScript.RegExp"): RegExp.Global = True
    RegExp.Pattern = "[\w]{1,}@[\w]{1,}" & repl1$ & "[\w]{1,}"
    If RegExp.test(txt) Then
        Set objMatches = RegExp.Execute(txt)
        For i = 0 To objMatches.Count - 1
            addr = objMatches.Item(i).Value
            addr = Replace(addr, repl1$, "."): addr = Replace(addr, repl2$, "-")
            coll.Add addr, addr    ' только уникальные адреса
       Next
    End If
End Sub