Sub Rassemble_Mails()
Dim TabMail As Variant
Dim Ligne As Integer
Dim Colonne As Integer
Dim DerLigne As Integer
Const ColRgtMails = "D" 'Regroupement E-Mails
Const ColMail1 = "E" 'Mail1
Const ColMail2 = "F" 'E-Mail2
Const ColMail3 = "G" 'E-Mail3
Application.ScreenUpdating = False
Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtMails & 1) = "E-Mails"
DerLigne = Range("A65000").End(xlUp).Row
TabMail = Sheets("Contacts").Range(Sheets("Contacts").Cells(2, 5), Sheets("Contacts").Cells(DerLigne, 7))
ReDim Preserve TabMail(LBound(TabMail, 1) To UBound(TabMail, 1), LBound(TabMail, 2) To UBound(TabMail, 2) + 1)
For Ligne = LBound(TabMail, 1) To UBound(TabMail, 1)
If TabMail(Ligne, 1) <> Empty Then
TabMail(Ligne, 4) = TabMail(Ligne, 1) & vbCrLf & TabMail(Ligne, 2) & vbCrLf & TabMail(Ligne, 3)
Else
TabMail(Ligne, 4) = TabMail(Ligne, 2) & vbCrLf & TabMail(Ligne, 3)
End If
Next Ligne
Sheets("Contacts").Range(ColRgtMails & "2").Resize(UBound(TabMail, 1), 1).Value = Application.Index(TabMail, , 4)
'Suppression des anciennes colonnes mail
Columns(ColMail1 & ":" & ColMail3).Delete shift:=xlToLeft
Application.ScreenUpdating = True
End Sub