XL 2016 Doublons

[dav59]

Bonjour les Amis
Une petite aide
je recherche code vba pour recherche sur une feuille les doublons de la ligne 1
pour copier les doublons avec la cellule de dessous de chaque doublons
voir exemple sur la feuil2

Merci beaucoup

 

[job75]

Bonjour dav59,

Le code de la 2ème feuille :

Private Sub Worksheet_Activate()
Dim d As Object, plage As Range, nlig%, c As Range, x$, n%, resu(), col%, lig%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Cells.Delete 'RAZ
Set plage = Feuil1.[A1].CurrentRegion.Rows(1).Cells
nlig = plage.Count + 2
For Each c In plage
    x = c
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise le rang
        ReDim Preserve resu(1 To nlig, 1 To n)
        resu(1, n) = x
        resu(2, n) = 2
    End If
    col = d(x)
    lig = resu(2, col) + 1: resu(2, col) = lig
    resu(lig, col) = c(2)
Next
[A1].Resize(nlig, n) = resu
Rows(2).Delete
Columns.AutoFit 'ajustement largeurs
End Sub

A+

 

[dav59]

Bonjour Job75
et merci beaucoup

 

[sylvanu]

Bonjour Dav, Job,
Franchement en retard, mais comme c'est fait ....
Un essai en PJ avec cette macro qui s'exécute lorsqu'on sélectionne la Feuil2 :

Sub Worksheet_Activate()
With Sheets("Feuil1")
    DC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    tablo = .Range(.Cells(1, 1), .Cells(2, DC))
End With
Cells.Clear
ReDim T(1 To 3 * DC, 1 To 3 * DC): C = -2: L = 1
For i = 1 To UBound(tablo, 2)
    If tablo(1, i) <> "" Then
        C = C + 3: Classe = tablo(1, i): T(1, C) = Classe: T(L, C + 1) = tablo(2, i): tablo(1, i) = ""
        For j = i + 1 To UBound(tablo, 2)
            If tablo(1, j) = Classe Then L = L + 1: T(L, C + 1) = tablo(2, j): tablo(1, j) = "":
        Next j
        T(1, C + 2) = "---":  L = 1
    End If
Next i
T(1, C + 2) = "": [A1].Resize(UBound(T, 1), UBound(T, 2)) = T: Columns.AutoFit
End Sub

 

[job75]

Pour tester j'ai recopié le tableau A1:N12 de la 1ère feuille sur (seulement) 4200 colonnes.

Chez moi la macro du post #2 s'exécute en 0,05 seconde, c'est quasi instantané.

La macro du post #4 s'exécute en 115 secondes, normal avec les boucles imbriquées.

 

[job75]

Pour terminer, si l'on veut que les résultats soient configurés comme indiqué au post #1, utilisez :

Private Sub Worksheet_Activate()
Dim d As Object, r As Range, nlig%, n%, x$, resu(), col%, lig%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Cells.Clear 'RAZ
Set r = Feuil1.[A1].CurrentRegion.Rows(1).Cells
nlig = r.Count
n = 1
For Each r In r
    x = r
    If Not d.exists(x) Then
        d(x) = n 'mémorise le rang
        ReDim Preserve resu(1 To nlig, 1 To n + 2)
        resu(1, n + 1) = x
        n = n + 3
    End If
    col = d(x)
    lig = resu(1, col) + 1: resu(1, col) = lig 'numérotation
    resu(lig, col + 2) = r(2)
Next
[A1].Resize(nlig, n - 1) = resu
With Rows(1).SpecialCells(xlCellTypeConstants, 1)
    .ColumnWidth = 2
    .ClearContents 'efface la numérotation
End With
Columns(1).Delete
End Sub

 

[dav59]

Bonjours
je vous remercie tout les deux
merci beaucoup