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