fehlen denn Addressen oder sind sie unvollständig?  Ich habe den Code etwas komentiert. Was du nicht benötigst z.b. den letzen Teil mit Spalte B, kannst du ja rausnehmen. Die  Referenzen auf Zellen und Spalten  gelten für das aktive Blatt. Willst du die Namen von einem anderen Blatt holen ,dann muß noch das Tabellenblatt davor.

 'Zellwerte zeilenweise aufteilen
    Do While Cells(i, 1) <> ""
       arr = Split(Cells(i, 1), ";") 'Zellinhalt Spalte A in Array(Datenfeld) schreiben
    'Spalte
       'Zellbereich an Arraygröße anpassen und Array in Tabellenblatt schreiben
       Cells(i, 2).Resize(, UBound(arr) + 1) = arr
      i = i + 1
    Loop
     
    'adressen umschreiben und in dictionary speichern
    'dazu wird der benutzte Datenbereich des Blattes ausgewertet
    For x = 2 To i - 1
     
     'schleife von Spalte 2 bis letzte Spalte des benutzten Bereiches
     For cnt = 2 To UsedRange.SpecialCells(xlCellTypeLastCell).Column
          
          If Cells(x, cnt).Value <> "" Then 'nur gefüllte Zellen bearbeiten
            strAdr = Replace(Trim(Cells(x, cnt).Value), " ", ".") 'Leerzeichen zwischen Namen durch Punkt ersetzen
            strAdr = strAdr & "@xy.com"   'domain an Namen anhängen
            If Not myAddresses.Exists(strAdr) Then
              myAddresses.Add strAdr, 1    'nur nicht vorhandene Adresse in dictionary schreiben
            End If
          End If
     Next cnt
   Next x

   'Zellbereich Leer machen
   Range(Cells(2, 2), Cells(x, cnt)).ClearContents
   'eindeutige Adressen ins Tabellenblatt Spalte B schreiben
   Cells(2, 2).Resize(myAddresses.Count).Value = Application.Transpose(myAddresses.Keys)
   Columns(2).AutoFit 'Spaltenbreite anpassen