Excel - alle E-mail Adressen von einem Blatt in neues Blatt extrahieren

Sub EMailsSuchen()
    Dim zielSheet As Worksheet, ws As Worksheet, regex As Object, cell As Range
    ' zielsheet  
    Set zielSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    zielSheet.Name = "Ergebnis"  
    ' regex  
    Set regex = CreateObject("vbscript.regexp")  
    regex.Global = True: regex.IgnoreCase = True
    regex.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}\b"  
    ' für jedes sheet  
    For Each ws In Sheets
        ' jede Zelle im Sheet  
        For Each cell In ws.UsedRange
            ' suche mails  
            Set matches = regex.Execute(cell.Value)
            ' wenn Ergebnis  
            If matches.Count > 0 Then
                ' für jede Mail der Zelle  
                For Each Match In matches
                    ' wenn mail noch nicht gefunden wurde  
                    If zielSheet.Range("A:A").Find(Match.Value, LookIn:=xlValues) Is Nothing Then  
                        ' mail in neue Zelle schreiben  
                        zielSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Match.Value  
                    End If
                Next
            End If
        Next
    Next
    ' Ergebnis anzeigen  
    zielSheet.Activate
End Sub