Sub Extraire_mail()
Dim i&, j&, k&, T(), T2, dico As Object, Nb As Double, temp As String
Application.ScreenUpdating = False
[B:B].ClearContents
T = [A1].CurrentRegion.Value
Set dico = CreateObject("scripting.dictionary")
For i = LBound(T, 2) To UBound(T, 2)
For j = LBound(T) To UBound(T)
If InStr(1, T(j, i), "@") > 0 Then
dico(T(j, i)) = dico(T(j, i))
End If
Next j
Next i
T2 = dico.keys
Nb = Int(dico.Count \ 100)
For i = LBound(T2) To Nb
For j = LBound(T2) To Application.WorksheetFunction.Min(100, dico.Count - k - 1)
temp = temp & T2(k) & ";": k = k + 1
Next j
Cells(i + 1, 2) = temp: temp = ""
Next i
Application.ScreenUpdating = True
End Sub