[XL-2010] Regrouper valeurs identiques

Bonjour,

J'ai un fichier de 4500 lignes avec 1 tableau de 2 colonnes. Chaque colonne est constitué d'infos concernant des utilisateurs classés de la même façon : Nom,Prénom,Numéro de téléphone.

La majorité des utilisateurs présent dans une colonne sont présent dans la colonne d'à coté. Les utilisateurs peuvent être présent dans une colonne 1 fois et 4 fois dans l'autre colonne. Je cherchais donc une macro qui pourrait renvoyé chaque valeur identique face à face dans chaque colonne

Sub test()
Columns("G:H").ClearContents
Ligne = 1
tablo1 = Range("A2:A" & Range("A4700").End(xlUp).Row)
tablo2 = Range("B2:B" & Range("B4700").End(xlUp).Row)
For n = LBound(tablo1) To UBound(tablo1)
 Cells(Ligne, 4) = tablo1(n, 1)
  For m = LBound(tablo2) To UBound(tablo2)
     If tablo1(n, 1) = tablo2(m, 1) Then
        Cells(Ligne, 5) = tablo2(m, 1)
        tablo2(m, 1) = ""
     End If
  Next m
  Ligne = Ligne + 1
Next n
  For m = LBound(tablo2) To UBound(tablo2)
    If tablo2(m, 1) <> "" Then
     Cells(Ligne, 5) = tablo2(m, 1)
     Ligne = Ligne + 1
    End If
  Next m
End Sub

Mais tout le tableaux se décale car lorsque il y'a plusieurs cellules identiques dans une colonne et pas dans l’autre elle n’arrive pas a laisser de cellules vides la ou il n'y a rien mais elle envoie l’utilisateur suivant. Je met une partie du fichier pour que ce soit plus simple a comprendre.

Je voudrais donc que lorsque un utilisateur est présent plus de fois dans la colonne "collectes long" que dans la colonne "AD" les cellules ou il n'y a rien pour "AD" soit vides face a ceux du "Collectes long"

Exemple:

Collectes long AD

1 1

1 1

1

2 2

3

4 4

4 4

Merci d'avance,

Bonjour et bienvenue sur le forum

Un essai à tester. Te convient-il ?

Bye !

Bonjour gmb, yakeem, le forum

En attendant que yakeem se manifeste, je verrai plutôt les choses de cette façon.

Option Explicit
Sub test()
Dim a, w(), t As Byte, i As Long, n As Long, x, y
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For t = 1 To 2
                For i = 2 To UBound(a, 1)
                    If a(i, t) <> "" Then
                        If Not .exists(a(i, t)) Then
                            ReDim w(1 To 3)
                            ReDim tablo(1 To 2, 1 To 1)
                        Else
                            w = .Item(a(i, t))
                            tablo = w(3)
                        End If
                        w(t) = w(t) + 1
                        If UBound(tablo, 2) < Application.Max(w(1), w(2)) Then
                            ReDim Preserve tablo(1 To 2, 1 To UBound(tablo, 2) + 1)
                        End If
                        tablo(t, w(t)) = a(i, t)
                        w(3) = tablo
                        .Item(a(i, t)) = w
                    End If
                Next
            Next
            x = .keys: y = .items
        End With
    End With
    Application.ScreenUpdating = False
    'Restitution et mise en forme
    With Sheets("Feuil2").Cells(1)
        .Parent.Cells.Clear
        .Resize(1, UBound(a, 2)) = a
        n = 1
        For i = 0 To UBound(x)
            With .Offset(n).Resize(UBound(y(i)(3), 2), UBound(y(i)(3), 1))
                .Value = Application.Transpose(y(i)(3))
                .BorderAround Weight:=xlThin
                n = n + .Rows.Count
            End With
        Next
        With .CurrentRegion
            .Borders(xlInsideVertical).Weight = xlThin
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            With .Rows(1)
                .Font.Bold = True
                .BorderAround Weight:=xlThin
                .Cells(1).Interior.ColorIndex = 44
                .Cells(2).Interior.ColorIndex = 43
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89