Sub ExtraireAdressesCourriels()
Dim c As Range ' variable range d'une cellule parcourue par la boucle for
Dim t() As String ' Tableau de résultats
Dim i As Integer ' indice de tableau
'Travailler sur le tableau de la feuille GHM
With ThisWorkbook.Sheets("GHM").Range("A1").CurrentRegion
'
' Eviter la ligne d'entête
With .Offset(1).Resize(.Rows.Count - 1)
ReDim t(1 To .Rows.Count)
' Boucler sur les cellules de la cinquième colonne
For Each c In .Columns(5).Cells
' si la cellule parcourue contient un lien hypertexte
If c.Hyperlinks.Count > 0 Then
i = i + 1
' S'il s'agit d'un lien mailto
If Left(LCase(c.Hyperlinks(1).Address), 7) = "mailto:" Then
' valoriser le tableau
t(i) = Replace(LCase(c.Hyperlinks(1).Address), "mailto:", "")
End If
End If
Next c
If i > 0 Then .Columns(6) = Application.Transpose(t)
End With
End With
End Sub
).
