Dédoublonnage complexe avec création valeurs uniques

Question

Après un acharnement de plusieurs heures depuis la semaine dernière, je finis par demander de l'aide. Voilà mon besoin : j'ai un fichier qui comporte 21 colonnes, dont 2 de ces colonnes contiennent au moins 1 adresse email (ou champ vide). - J'ai besoin de ne conserver qu'une adresse email unique par ligne , - et si 2 adresses emails sont différentes sur une même ligne je dois créer une nouvelle ligne reprenant ses contenus de champs (des autres colonnes), mais avec la 2ème adresse email unique . &gt; La référence de ce fichier excel vous l'avez compris, doit être l'adresse email. 1 ligne = 1 adresse email unique. Je joins un exemple de fichier. Pouvez-vous m'aider ? Merci par avance de votre aide précieuse...

Klin89 · Accepted Answer

Re dog75,

Plutôt celle-ci :

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, k As Long, n As Long
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
    End With
    ReDim b(1 To ((UBound(a, 1) - 1) * 2) + 1, 1 To (UBound(a, 2) - 1))
    For j = 1 To UBound(b, 2) - 1
        b(1, j) = a(1, j)
    Next
    b(1, UBound(b, 2)) = "Mail"
    n = 1
    For i = 2 To UBound(a, 1)
        For j = 20 To UBound(a, 2)
            If Not IsEmpty(a(i, j)) Then
                n = n + 1
                For k = 1 To UBound(b, 2) - 1
                    b(n, k) = a(i, k)
                Next
                b(n, UBound(b, 2)) = a(i, j)
                If j = UBound(a, 2) Then
                    If a(i, j) = a(i, j - 1) Then n = n - 1
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .Interior.ColorIndex = 43
            .BorderAround Weight:=xlThin
        End With
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

LouReeD · Answer

Pour bien comprendre : ne faut - il pas une deuxième ligne pour la dernière référence ? en effet il y un email 1 et 11 ! Alors oui l'email 1 est déjà inscrit pour PACA au début du tableau mais l'ID n'est pas le même... Alors ? @ bientôt LouReeD...

Klin89 · Answer

A tester, restitution en "Feuil2" préalablement créée Option Explicit Sub test() Dim a, b(), i As Long, j As Long, k As Long, n As Long With Sheets("Feuil1").Cells(1).CurrentRegion a = .Value End With For i = 2 To UBound(a, 1) If IsEmpty(a(i, UBound(a, 2) - 1)) Then a(i, UBound(a, 2) - 1) = a(i, UBound(a, 2)) End If Next ReDim b(1 To ((UBound(a, 1) - 1) * 2) + 1, 1 To (UBound(a, 2) - 1)) For j = 1 To UBound(b, 2) - 1 b(1, j) = a(1, j) Next b(1, UBound(b, 2)) = "Mail" n = 1 For i = 2 To UBound(a, 1) For j = 20 To UBound(a, 2) n = n + 1 For k = 1 To UBound(b, 2) - 1 b(n, k) = a(i, k) Next b(n, UBound(b, 2)) = a(i, j) If j = UBound(a, 2) Then If a(i, j) = a(i, j - 1) Then n = n - 1: Exit For End If Next Next Application.ScreenUpdating = False With Sheets("Feuil2").Cells(1).Resize(n, UBound(b, 2)) .CurrentRegion.Clear .Value = b .Font.Name = "calibri" .Font.Size = 10 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Borders(xlInsideVertical).Weight = xlThin .BorderAround Weight:=xlThin With .Rows(1) .Font.Size = 11 .Interior.ColorIndex = 43 .BorderAround Weight:=xlThin End With .Columns.AutoFit End With Application.ScreenUpdating = True End Sub Une chose me turlupine, ce sont les cellules vides en colonne Mail 1 et non Mail 2 Dans ton exemple, les différents cas sont-ils tous représentés 8) klin89...

tulipe_4 · Answer

Un essai foireux par formule cela boite a PACA a cause du texte1 et texte2 cordialement...