Recherche l'utilisation la plus fréquente

Module, mais c'est bien sur

6,847656 secondes

Du vert sur les doublons

8600 ligne dont les doublons

Me reste à faire un choix avec les doublons 8)

Des heures, si ce n'est des jours de boulot en quelques secondes

Merci

Re,

erreur de code, voir la réponse suivante

Ensuite, tu te mets en H1, et tu fais Données/Filtre Automatique

Filtre sur Doublons

Re-,

petite erreur dans le code que je viens de te donner

rectifie comme ceci (en fin de code)

        If Cells(I + 1, 7).Value <> Cells(I, 7).Value Then
            Cells(I, 5).Resize(1, 4).Delete Shift:=xlUp
        Else
            Cells(I, 5).Resize(2, 3).Interior.ColorIndex = 4
            Cells(I, 8).Resize(2, 1).Value = "Doublons"
        End If

et en début de code :

Range("E2:H" & [E65000].End(xlUp).Row + 1).Clear

Comme ça

Sub References()
Dim Cel As Range
Range("E2:H" & [E65000].End(xlUp).Row + 1).Clear
Dim Concat As String
Dim NbLig As Long, I As Long
Dim Maquettes As Object, Maquettes2 As Object
Application.ScreenUpdating = False
t = Timer
Set Maquettes = CreateObject("Scripting.Dictionary")
Range("E2:G" & [E65000].End(xlUp).Row + 1).Clear
For Each Cel In Range("C2:C" & [C65000].End(xlUp).Row)
    Concat = Cel.Value & ";" & Cel.Offset(0, -2).Value
    If Not Maquettes.Exists(Concat) Then
        Maquettes.Add Concat, 1
    Else
        Maquettes.Item(Concat) = Maquettes.Item(Concat) + 1
    End If
Next Cel
NbLig = Maquettes.Count
[H1] = NbLig
[E2].Resize(NbLig, 1).Value = Application.Transpose(Maquettes.Keys)
Range("E2:E" & NbLig + 1).TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Semicolon:=True
[G2].Resize(NbLig, 1).Value = Application.Transpose(Maquettes.Items)
Range("E1:G" & NbLig + 1).Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:=Range("G2") _
        , Order2:=xlAscending, Header:=xlYes
Set Maquettes2 = CreateObject("Scripting.Dictionary")
For I = NbLig + 1 To 2 Step -1
    If Not Maquettes2.Exists(Cells(I, 5).Value) Then
        Maquettes2.Add Cells(I, 5).Value, Cells(I, 5).Value
    Else
        If Cells(I + 1, 7).Value <> Cells(I, 7).Value Then
            Cells(I, 5).Resize(1, 3).Delete Shift:=xlUp
        Else
            Cells(I, 5).Resize(2, 3).Interior.ColorIndex = 4
                    If Cells(I + 1, 7).Value <> Cells(I, 7).Value Then
            Cells(I, 5).Resize(1, 4).Delete Shift:=xlUp
        Else
            Cells(I, 5).Resize(2, 3).Interior.ColorIndex = 4
            Cells(I, 8).Resize(2, 1).Value = "Doublons"
        End If
        End If
    End If
Next I
Columns("E:G").HorizontalAlignment = xlCenter
MsgBox Timer - t
End Sub

la j'ai une nouvelle colonne avec "Doublons" dedans mais pas en face des doublons

Re-,

je ne sais plus ce que j'avais fait, mais ça fonctionne avec mon code..

Et comme j'ai pas trop envie de contrôler....

Je te donne le code qui fonctionne

Si tu veux t'amuser à regarder les différences....

Sub References()
Dim Cel As Range
Dim Concat As String
Dim NbLig As Long, I As Long
Dim Maquettes As Object, Maquettes2 As Object
Application.ScreenUpdating = False
t = Timer
Set Maquettes = CreateObject("Scripting.Dictionary")
Range("E2:H" & [E65000].End(xlUp).Row + 1).Clear
For Each Cel In Range("C2:C" & [C65000].End(xlUp).Row)
    Concat = Cel.Value & ";" & Cel.Offset(0, -2).Value
    If Not Maquettes.Exists(Concat) Then
        Maquettes.Add Concat, 1
    Else
        Maquettes.Item(Concat) = Maquettes.Item(Concat) + 1
    End If
Next Cel
NbLig = Maquettes.Count
[H1] = NbLig
[E2].Resize(NbLig, 1).Value = Application.Transpose(Maquettes.Keys)
Range("E2:E" & NbLig + 1).TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Semicolon:=True
[G2].Resize(NbLig, 1).Value = Application.Transpose(Maquettes.Items)
Range("E1:G" & NbLig + 1).Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:=Range("G2") _
        , Order2:=xlAscending, Header:=xlYes
Set Maquettes2 = CreateObject("Scripting.Dictionary")
For I = NbLig + 1 To 2 Step -1
    If Not Maquettes2.Exists(Cells(I, 5).Value) Then
        Maquettes2.Add Cells(I, 5).Value, Cells(I, 5).Value
    Else
        If Cells(I + 1, 7).Value <> Cells(I, 7).Value Then
            Cells(I, 5).Resize(1, 4).Delete Shift:=xlUp
        Else
            Cells(I, 5).Resize(2, 3).Interior.ColorIndex = 4
            Cells(I, 8).Resize(2, 1).Value = "Doublons"
        End If
    End If
Next I
Columns("E:G").HorizontalAlignment = xlCenter
MsgBox Timer - t
End Sub

Je regarde ça demain matin

Vraiment un gros merci

Génial, ça fonctionne avec "Doublons" devant les bonnes lignes