Accueil

Liste sans doublons
Liste sans doublons triée 1 colonne et 2 colonnes
Liste des doublons
Suppression de doublons dans une colonne
Repérage des doublons
Repérer les doublons 2 colonnes
Fusion de lignes doublons
Suppression de doublons dans une BD
Suppression de doublons avec totalisation
Suppression doublons rapide avec Dictionary
Suppression doublons 2 listes
Fonction sans doublons d'une liste
Fonction liste sans doublons triée
Eléments communs à 2 listes
Comparaison de 2 listes de prix
Différence entre 2BD
Lignes qui existent dans BD1 et pas dans BD2
Liste des doublons et des valeurs uniques
Comparaison de 2 BD par MFC
Communs 2 BD par filtre élaboré
Comparaison de 2 BD:Modifications, communs, ajouts, fusion
Lignes communes de 2BD (sur toutes les colonnes)
Coloriage des communs à 2 BD
Eléments communs à plusieurs feuilles
Comparaison sur arrondi de numérique
Fusion de 2BD
Fusion sans doublons de plusieurs BD
Fusion/Consolidation BD
Comparaison BD rapide
Compare les codes et pays de 2 BD
Repérage des doublons 3D
Elimine les doublons dans une cellule
Doublons dans une cellule
Suppression de lignes vides
Suppression de lignes
Fonction liste sans doublons triée multi-zones
Suppression de doublons multi-feuilles
Liste des villes en doublon
Extraction des doublons d'une BD avec le filtre élaboré
Suppression de doublons avec totalisation
Fonction de suppression de doublons
Nombre d'occurences des doublons
Génère des identifiants

Liste sans doublons

0,26 sec pour 16.000 lignes

Set mondico = CreateObject("Scripting.Dictionary")
For Each c In Range("a2", [a65000].End(xlUp))
   mondico(c.Value) = ""
Next c
[c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)

0,04 sec pour 16.000 lignes

Set mondico = CreateObject("Scripting.Dictionary")
a = Range("a2", [a65000].End(xlUp)).Value
For Each c In a
    mondico(c) = ""
Next c
[c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)

Suppression de doublons dans une colonne

Supprime les doublons d'une colonne sans supprimer les lignes (0,1s pour 10.000 lignes).

SupDoublonsDansColonne
SupDoublonsPlusieursColonnes

Sub SupDoublonsColonne()
  Set d = CreateObject("Scripting.Dictionary")
  Set début = Cells(2, 2)
  a = Range(début, début.End(xlDown))
  For Each c In a
    d(c) = ""
  Next c
  Range(début, début.End(xlDown)).ClearContents
  début.Resize(d.Count, 1) = Application.Transpose(d.keys)
End Sub

Avec la méthode traditionnelle, la colonne doit être triée.
Pour 10.000 lignes, le temps de suppression est >10s pour un taux de suppression de 10%

Sub SupDoublonsColonneTradi()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  For i = [C65000].End(xlUp).Row To 2 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i, 2).Delete Shift:=xlUp
  Next i
  Application.Calculation = xlCalculationAutomatic
End Sub

Liste sans doublons triée 1 colonne et 2 colonnes

A partir d'une liste avec doublons en colonne A, on obtient une liste sans doublons triée en colonne C.

ListeSansDoublonsTriée
FonctionListeSansDoublonsTriée
FonctionListeSansDoublonsTriée2
FormCascadeSansDoublons2colonnesDict
FormCascadeSansDoublons2colonnesTrié
FormCascadeSansDoublons2colonnesMAC

Version1

Sub SansDoublonsTrié1()
  Dim temp()
  Set f = Sheets("Feuil1")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Range(f.[a2], f.[a65000].End(xlUp)).Value
  For Each c In a
     mondico(c) = ""
  Next c
  Set dest = f.Range("C2")
  dest.Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  dest.Resize(mondico.Count, 1).Sort Key1:=dest, Order1:=xlAscending
  Set mondico = Nothing ' libère mondico
End Sub

Version2

Sub SansDoublonsTrié2()
  Dim temp()
  Set f = Sheets("Feuil1")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Range(f.[a2], f.[a65000].End(xlUp)).Value ' tableau pour rapidité
  For Each c In a
    mondico(c) = ""
  Next c
  temp = mondico.keys ' dans un tableau pour tri
  Call tri(temp, LBound(temp), UBound(temp))
  f.[C2].Resize(mondico.Count, 1) = Application.Transpose(temp)
  Set mondico = Nothing ' libère mondico
End Sub


Sub tri(a(), gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

S'il y a des Majuscules/Minuscules

MonDico(Ucase(c) )= ""

ou

MonDico(Application.Proper(c) )= ""

Liste des doublons

Sub ListeDoublons()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
    If d1.exists(c.Value) Then d2(c.Value) = ""
    d1(c.Value) = ""
  Next c
  If d2.Count > 0 Then [c2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
End Sub

Liste des adresses des doublons

Doublons
Dupont   $A$3-$A$7-
Balu       $A$2-$A$8-$A$13-
Durand   $A$4-$A$12-

Sub ListeDoublonsColA()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
    If c <> "" And d1.exists(c.Value) Then d2(c.Value) = d1(c.Value) & c.Address & "-"
    d1(c.Value) = d1(c.Value) & c.Address & "-"
  Next c
  If d2.Count > 0 Then
    [J2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    [K2].Resize(d2.Count, 1) = Application.Transpose(d2.Items)
  End If
End Sub

Liste des doublons d'une BD avec le filtre élaboré

En E2:=NB.SI(B:B;B2)>1

ListeDoublonsFiltreElaboré

Sub FiltreDoublons()
  [A1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], CopyToRange:=[G1:I1], Unique:=False
  [G1].CurrentRegion.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=lGuess
End Sub

Avec Dictionary

ListeDoublonsDico

Sub ListeDoublons() 'rapide
   Set f = Sheets("feuil1")
   Set f2 = Sheets("feuil2")
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In f.Range("b2", f.[b65000].End(xlUp))
     mondico(c.Value) = mondico(c.Value) + 1
   Next c
   ligne = 2
   For i = 2 To f.[b65000].End(xlUp).Row
     If mondico(f.Cells(i, 2).Value) > 1 Then
       f.Cells(i, 1).Resize(, 3).Copy f2.Cells(ligne, 1)
       ligne = ligne + 1
     End If
   Next i
   f2.[A2].CurrentRegion.Sort Key1:=f2.[C2], Order1:=xlAscending, Header:=xlGuess
End Sub

Compare 2 BD

Compare la présence de codes dans BD1 et BD2 en colonne A.

CompareBD

Code
4645 BD1
4949 les deux
7006 les deux
7012 les deux
7190 BD1
7336 BD1
6656 BD2
7566 BD2
7605 BD2

CompareBD()
  Set f = Sheets("BD1")
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In Range(f.[a2], f.[a65000].End(xlUp))
    d1(c.Value) = "BD1"
  Next c
  Set f = Sheets("BD2")
  For Each c In Range(f.[a2], f.[a65000].End(xlUp))
     If d1.exists(c.Value) Then d1(c.Value) = "les deux" Else d1(c.Value) = "BD2"
  Next c
  Sheets("synthèse").[a2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  Sheets("synthèse").[b2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
End Sub

Repérage des doublons

On veut colorier les doublons.

Sub ColoriageDoublons()
  [A:A].Interior.ColorIndex = xlNone
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    If c<>"" then  mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
    If mondico.Item(c.Value) > 1 Then c.Interior.ColorIndex = 4
  Next c
End Sub

Pour 12.000 lignes, avec la fonction Nb.Si(), on obtient un temps de 15 secondes au lieu de 0,5 seconde avec l'objet Dictionary.

Sub ColoriageDoublonsNbSi
  Application.ScreenUpdating = False
  [a:a].Interior.ColorIndex = xlNone
  For Each c In Range("a2", [a65000].End(xlUp))
     If Application.CountIf([a2:a12000], c) > 1 Then c.Interior.ColorIndex = 4
  Next c
End Sub

Avec MFC

Sub ColoriageMFC()
  Set champ = Range("a2:a" & [a65000].End(xlUp).Row)
  champ.Select
  champ.FormatConditions.Delete
  champ.FormatConditions.Add Type:=xlExpression, Formula1:="=NB.SI(" & champ.Address & " ;A2)>1"
  champ.FormatConditions(1).Interior.ColorIndex = 8
End Sub

Ci dessous, chaque groupe a une couleur différente

Sub GroupColor()
  couleurs = Array(1, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    If c <> "" Then mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
   If c <> "" Then
     nocoul = (Application.Match(c.Value, mondico.keys, 0)) Mod UBound(couleurs)
     If mondico.Item(c.Value) > 1 Then c.Interior.ColorIndex = couleurs(nocoul)
   End If
  Next c
End Sub

ColorGroup
ColorGroup2
ColorGroup4Colonnes
ColorGroupComment
ColorDoublonsLigne
ColoriageDoublonsCommentMultiFeuilles
ColoriageDoublonsTriplons

Doublons 2 critères

Le test de doublon se fait sur les colonnes A et C.

Doublons 2 Critères

Sub GroupColor2CritèresColAColC()
  couleurs = Array(1, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44,    45, 46, 50, 53)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    clé = c.Value & c.Offset(, 2)
    mondico.Item(clé) = mondico.Item(clé) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
    clé = c.Value & c.Offset(, 2)
    nocoul = (Application.Match(clé, mondico.keys, 0)) Mod UBound(couleurs)
    If mondico.Item(clé) > 1 Then c.Resize(, 4).Interior.ColorIndex = couleurs(nocoul)
  Next c
End Sub

Doublons 2 critères avec indication des nos de lignes

Color Group 1 critère commentaire
Color Group 1 critère HyperLien
Color Group 2 critères
Color Group 2 critères2

Sub GroupHyperLien()
  Application.ScreenUpdating = False
  Set Rng = Range("A2", [A65000].End(xlUp))
  Rng.Offset(, 1).Resize(, 5).Clear
  Rng.Interior.ColorIndex = xlNone
  couleurs = Array(3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46,    50, 53)
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Rng
    If c <> "" Then
      d.Item(c.Value) = d.Item(c.Value) + 1
      d2.Item(c.Value) = d2.Item(c.Value) & CStr(c.Row) & "|"
    End If
  Next c
  nf = ActiveSheet.Name
  For Each c In Rng
   If c.Value <> "" Then
     If d.Item(c.Value) > 1 Then
        nocoul = (Application.Match(c.Value, d.keys, 0)) Mod UBound(couleurs)
        c.Interior.ColorIndex = couleurs(nocoul)
        temp = c.Value
        b = Split(d2(temp), "|")
        For k = 0 To UBound(b) - 1
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(c.Row, k + 2), Address:="", SubAddress:="'" & nf & "'" & "!A" &            b(k), TextToDisplay:=b(k)
        Next k
      End If
    End If
  Next c
End Sub

Repérer les doublons entre 2 colonnes

Repérage des doublons entre 2 colonnes

Doublons 2 colonnesSimple

Sub DoublonsRapide2col()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("A1", [a65000].End(xlUp))
  Set plage2 = Range("B1", [B65000].End(xlUp))
  [A:B].Interior.ColorIndex = xlNone
  For Each c In plage1
    If c <> "" Then d1(c.Value) = ""
  Next c
  For Each c In plage2
    If d1.exists(c.Value) Then c.Interior.ColorIndex = 3
    If c <> "" Then d2(c.Value) = ""
  Next c
  For Each c In plage1
    If d2.exists(c.Value) Then c.Interior.ColorIndex = 4
  Next c
End Sub

Repérage de tous les doublons (entre 2 colonnes + doublons dans chaque colonne)

Sub DoublonsRapideTous()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("A1", [a65000].End(xlUp))
  Set plage2 = Range("B1", [B65000].End(xlUp))
  [A:B].Interior.ColorIndex = xlNone
  For Each c In plage1
     If c <> "" Then d1(c.Value) = d1(c.Value) + 1
  Next c
  For Each c In plage2
  If c <> "" Then d2(c.Value) = d2(c.Value) + 1
    If d1.exists(c.Value) Then c.Interior.ColorIndex = 3
  Next c
  For Each c In plage1
    If d2.exists(c.Value) Then c.Interior.ColorIndex = 4
    If d1(c.Value) > 1 Then c.Interior.ColorIndex = 4
  Next c
  For Each c In plage2
    If d2(c.Value) > 1 Then c.Interior.ColorIndex = 3
  Next c
End Sub

Chaque groupe de doublons a une couleur différente

Doublons 2 colonnesCoulDiff

Sub DoublonsEntre2ColonnesCoulDiff()
  Set d = CreateObject("Scripting.Dictionary")
  couleurs = Array(3, 4, 6, 7, 8, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
  Set plage1 = Range("A2:A" & [a65000].End(xlUp).Row)
  Set plage2 = Range("B2:B" & [b65000].End(xlUp).Row)
  Union(plage1, plage2).Interior.ColorIndex = xlNone
  For Each C In plage1
     d.Item(C.Value) = d.Item(C.Value) & C.Row & "-"
  Next C
  For Each C In plage2
     If d.exists(C.Value) Then
       nocoul = (Application.Match(C.Value, d.keys, 0)) Mod UBound(couleurs)
       C.Interior.ColorIndex = couleurs(nocoul)
       a = Split(d.Item(C.Value), "-")
       For k = LBound(a) To UBound(a) - 1
         tmp = a(k) - plage1.Row + 1
         plage1(tmp).Interior.ColorIndex = couleurs(nocoul)
       Next k
     End If
   Next C
End Sub

Doublons 2 colonneCommentaire

Indique les no des lignes qui contiennent des doublons.

Liste des doublons en colonne A et liste des doublons en colonne B

Sub ListeDoublonsColA()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
    If c <> "" And d1.exists(c.Value) Then d2(c.Value) = d1(c.Value) & c.Address & "-"
    d1(c.Value) = d1(c.Value) & c.Address & "-"
  Next c
  If d2.Count > 0 Then
    [J2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    [K2].Resize(d2.Count, 1) = Application.Transpose(d2.Items)
  End If
End Sub

Liste des doublons entre 2 colonnes

Sub DoublonsEntre2ColonnesRapport2()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("a2:a" & [a65000].End(xlUp).Row)
  Set plage2 = Range("b2:b" & [b65000].End(xlUp).Row)
  For Each c In plage2
     d1.Item(c.Value) = d1.Item(c.Value) & c.Address & "-"
  Next c
  I = 2
  For Each c In plage1
    If d1.exists(c.Value) Then
       Cells(I, "P") = c
       Cells(I, "Q") = c.Address
       Cells(I, "R") = d1.Item(c.Value)
       I = I + 1
    End If
  Next c
End Sub

Doublons dans un champ

DoublonsDansUnChamp

Doublons en ligne

DoublonsLigne

Sub ColoriageDoublonsNbSi()
  [A1].CurrentRegion.Interior.ColorIndex = xlNone
  Application.ScreenUpdating = False
  For i = 1 To [A65000].End(xlUp).Row
    Set champ = Cells(i, 1).Resize(, 4)
    For c = 1 To 4
      If Application.CountIf(champ, Cells(i, c)) > 1 Then Cells(i, c).Interior.ColorIndex = 6
    Next c
  Next i
End Sub

Doublons sur plusieurs noms par cellule

Plusieurs noms par cellule.

DoublonsCellules

MFC: =doublons(A2;$A$2:$A$7)

Function doublons(nom As Range, noms As Range)
 Application.Volatile
 a = Split(nom, " ")
 For Each k In a
   If Application.CountIf(noms, "*" & Trim(k) & "*") > 1 Then doublons = True
 Next k
End Function

Fusion de lignes doublons

On regroupe toutes les informations des doublons Nom+prénom dans une seule ligne.

Fusion lignes doublons
Fusion lignes doublons 2
Regroupe lignes doublons SousTotal
Regroupe lignes doublons sous Total Tableau 2D
Regroupe lignes doublons sous Total Tableau 2D 2
Sous Total 2col

Sub RegroupeLigneS()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("BD")
  Set f2 = Sheets("résultats")
  ncol = f1.[a1].CurrentRegion.Columns.Count
  nlig = f1.[a1].CurrentRegion.Rows.Count
  d1.CompareMode = vbTextCompare
  For ligne = 1 To nlig
    crit = f1.Cells(ligne, 1) & f1.Cells(ligne, 2) ' nom+prenom
    d1(crit) = ""
    ligT = Application.Match(crit, d1.keys, 0)
    For col = 1 To ncol
      If f1.Cells(ligne, col) <> "" Then f2.Cells(ligT, col) = f1.Cells(ligne, col).Text
    Next col
    If f1.Cells(ligne, ncol) <> "" Then f1.Cells(ligne, ncol).Copy f2.Cells(ligT, ncol)
  Next ligne
End Sub

Sur cette version, nous fusionnons tous les numéros de tph de chaque personne dans une cellule.

Fusion lignes doublons2

Suppression de doublons dans une BD

Suppression classique

Cette méhode devient lente si le nombre de lignes à supprimer est important.

SupDoublonsTradi

Sub supDoublonsTradi()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   [A1].Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
   For i = [A65000].End(xlUp).Row To 2 Step -1
     If Cells(i, 1) = Cells(i - 1, 1) Then Rows(i).Delete
   Next i
   Application.Calculation = xlCalculationAutomatic
End Sub

Pour conserver le dernier:

Sub supDoublonsTradiGardeDernier()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  [A1].Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
  i = 2
  Do While Cells(i, 1) <> ""
     If Cells(i, 1) = Cells(i + 1, 1) Then Rows(i).Delete Else i = i + 1
  Loop
 Application.Calculation = xlCalculationAutomatic
End Sub

Suppression de doublons avec Totalisation des montants

Les montants sont totalisés.

SupDoublonsTotal

Sub supDoublonsTotal()
  [A2].CurrentRegion.Sort , key1:=[A2], Header:=xlYes
  ligne = 2
  Do While Cells(ligne, 1) <> ""
    If Cells(ligne, 1) = Cells(ligne + 1, 1) Then
       Cells(ligne, "c") = Cells(ligne, "c") + Cells(ligne + 1, "c")
       Rows(ligne + 1).Delete
    Else
      ligne = ligne + 1
    End If
   Loop
End Sub

Regroupe les prénoms des enfants

Les prénoms des enfants sont regroupés sur la même ligne.

Sub supDoublonsRegroupe()
  ligne = 2: col = 4
  Do While Cells(ligne, 1) <> ""
    If Cells(ligne, 1) = Cells(ligne + 1, 1) Then
       Cells(ligne, col) = Cells(ligne + 1, 3)
       col = col + 1
        Rows(ligne + 1).Delete
     Else
       ligne = ligne + 1
       col = 4
     End If
   Loop
End Sub

Suppression de doublons rapide dans une BD avec Dictionary

0,23 sec pour 10.000 éléments

Le test de doublon se fait seulement sur la colonne A

SupDoublons Dictionary
SupDoublons Dictionary Totalisation
SupDoublonsGardeLesNonDoublons

Sub SupDoublonsColA()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    If Not mondico.exists(a(i, 1)) Then
      mondico.Add a(i, 1), 1
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  Sheets("resultat").[A1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

La version ci dessous conserve la présentation.

SupDoublonsDictionary Présentation

Sub SupDoublonsColA()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A2:A" & f1.[A65000].End(xlUp).Row)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    If Not mondico.exists(a(i, 1)) Then
       mondico.Add a(i, 1), ""
       a(i, 1) = 0
    Else
      a(i, 1) = "sup"
    End If
  Next
  f1.Columns("b:b").Insert Shift:=xlToRight
  f1.[B2].Resize(UBound(a)) = a
  f1.[A2].CurrentRegion.Sort Key1:=f1.Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  f1.Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  f1.Columns("b:b").Delete Shift:=xlToLeft
End Sub

On considère que les lignes pour lesquelles toutes les colonnes sont identiques sont des doublons.

Sub SupDoublonsToutesCol()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    temp = ""
    For k = 1 To UBound(a, 2): temp = temp & a(i, k): Next
    If Not mondico.exists(temp) Then
      mondico.Add temp, 1
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  Sheets("resultat").[A1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

Suppression de doublons sans modifier l'ordre

Sur colonne A

Sub supdoublons()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set champ = Range("A1:A" & [A65000].End(xlUp).Row)
  For i = [A65000].End(xlUp).Row To 1 Step -1
    If Application.CountIf(champ, Cells(i, 1)) > 1 Then
        Cells(i, 1).Delete Shift:=xlUp ' ou Rows(i).Delete
    End If
  Next i
  Application.Calculation = xlAutomatic
End Sub

Doublons sur colonne A et C avec Dictionary

Le test de doublon se fait sur la concaténation des colonnes A et C.
Rapide si taux de suppression faible. 2 s pour 10.0000 lignes et taux suppression 5%

SupDoublonsDictionary

Sub OrdreRespectéDictionary()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  i = 2
  Do While Cells(i, "A") <> ""
   If Not MonDico.Exists(Cells(i, "A") & Cells(i, "C")) Then
      MonDico(Cells(i, "A") & Cells(i, "C")) = ""
      i = i + 1
   Else
     Rows(i).EntireRow.Delete
   End If
Loop

Autre exemple

L'ordre est conservé. On garde le premier ou le dernier.
Le test de doublon se fait sur la colonne C.

SupDoublons

Sub GardeDernier()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  i = [A65000].End(xlUp).Row
  Do While i > 2
    temp = Cells(i, "C")
    If Not MonDico.Exists(temp) Then
      MonDico(temp) = ""
      i = i - 1
    Else
      Rows(i).EntireRow.Delete
      i = i - 1
   End If
  Loop
End Sub

Sub GardePremier()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  i = 2
  Do While i < [A65000].End(xlUp).Row
    temp = Cells(i, "C")
    If Not MonDico.Exists(temp) Then
      MonDico(temp) = ""
      i = i + 1
    Else
      Rows(i).EntireRow.Delete
    End If
  Loop
End Sub

Sub supX()
   [B2:B65000].SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
End Sub

Sur colonne A et C avec le filtre élaboré

Les doublons sont testés sur la concaténation des colonnes A et C.

SupDoublonsFiltre

Sub sup_Doublons()
  [A1].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[C2] _
     , Order2:=xlAscending, Header:=xlGuess
   [G:G].Insert Shift:=xlToRight
   [G2].Formula = "=AND(A1=A2,c1=c2)"
   [A1:E1000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[G1:G2]
   If MsgBox("Etes vous sûr?", vbYesNo) = vbYes Then
     Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
     Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
   Else
     MsgBox "Annulé"
   End If
   ActiveSheet.ShowAllData
   [G:G].Delete Shift:=xlToLeft
End Sub

Une autre façon consiste à extraire une liste sans doublons sur une autre feuille

Sub sup_Doublons2()
  [A1].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[C2],Order2:=xlAscending, Header:=xlGuess
  [G:G].Insert Shift:=xlToRight
  [G2].Formula = "=OR(A1<>A2,c1<>c2)"
  Sheets(2).Cells.ClearContents
  [A1:C1000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G1:G2], CopyToRange:=Sheets(2).[A1]
  [G:G].Delete Shift:=xlToLeft
End Sub

Extraction sans doublon:on veut garder le dernier

Filtre le dernier de chaque groupe (colonne D): 100,101,102,..
On masque les autres lignes.

FiltreElaboréDernier

Dans le critère en I2:=ESTERREUR(1/(D2=D3))

Sub FiltreElab()
  [A1:F10000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[I1:I2]
End Sub

-Logiquement, la formule du critère devrait être =D2<>D3
-Pour la dernière ligne (ligne11), l'interpréteur Excel va évaluer =D11<>D12 mais pour lui D12 n'appartient pas
au UsedRange. Cette ligne n'est donc pas prise en compte.
-Pour que la ligne D12 soit prise en compte, il faudrait q'une cellule quelconque après la ligne 11 soit documentée

-Avec 1/(D2=D3), on obtient une division par 0 à chaque fois que Dn<>Dn+1. Cette division par 0 est détectée par =EstErreur(1/(Dn=Dn+1).
-Pour la dernière ligne (ligne11), l'interpréteur Excel va évaluer =1/(D11=D12). D12 n'appartenant pas au UsedRange, il y a une erreur. Celle ci est également détectée par EstErreur()

Autre méthode sans le filtre élaboré

Sub Filtre()
  Set f = Sheets("BD")
  Set Mondico = CreateObject("Scripting.Dictionary")
  For i = f.[A65000].End(xlUp).Row To 2 Step -1
     If Not Mondico.Exists(f.Cells(i, "d").Value) Then Mondico(f.Cells(i, "d").Value) = "" Else f.Rows(i).Hidden = True
  Next i
End Sub

Extraction sans doublon:on veut garder le premier

Dans l'exemple, la BD est triée par An,format,vins,prix.
il y a deux fois la référence 2003 Armailhac 750Ml. On veut garder uniquement le premier fournisseur
(le moins cher).

Le critère en G2:=ESTERR(OU(1/(A1=A2);1/(B1=B2);1/(C1=C2)))

FiltreElaboréGardePremier

Suppression de doublons: on veut garder le km maximum

Les doublons sont testés sur la colonne A. On conserve la ligne avec le kilométrage maximum.

DoublonsMax

Sub test4()
  Application.ScreenUpdating = False
  a = Range("A3:C" & [C65000].End(xlUp).Row)
  Set dico = CreateObject("Scripting.Dictionary")
  Set dicoDate = CreateObject("Scripting.Dictionary")
  For i = LBound(a) To UBound(a)
    If a(i, 3) > dico(a(i, 1)) Then dico(a(i, 1)) = a(i, 3): dicoDate(a(i, 1)) = a(i, 2)
  Next i
  [E3].Resize(dico.Count) = Application.Transpose(dico.keys)
  [F3].Resize(dico.Count) = Application.Transpose(dicoDate.items)
  [G3].Resize(dico.Count) = Application.Transpose(dico.items)
End Sub

Autre méthode s'il y a plus de colonnes

Sub test3()
  Application.ScreenUpdating = False
  a = Range("A3:C" & [C65000].End(xlUp).Row)
  Set dico = CreateObject("Scripting.Dictionary")
  colKm = 3
  For i = LBound(a) To UBound(a)
    clé = a(i, 1)
    If dico.exists(clé) Then
      If a(i, colKm) > a(dico(clé), colKm) Then dico(clé) = i
    Else
      dico(clé) = i
    End If
  Next i
  ligne = 3
  For Each clé In dico.keys
    For k = 1 To UBound(a, 2): Cells(ligne, k + 4) = a(dico(clé), k): Next k
    ligne = ligne + 1
  Next
End Sub

Suppression lignes identiques

Supprime les lignes identiques (colonnes A,C,E) (2 sec pour 65.000 lignes)

SupLignesIdentiques

Sub SupLignesIdentiques()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Set mondico = CreateObject("Scripting.Dictionary")
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    temp = a(i, 1) & a(i, 3) & a(i, 5)
    mondico(temp) = mondico(temp) + 1
  Next
  For i = 1 To UBound(a)
    temp = a(i, 1) & a(i, 3) & a(i, 5)
    If mondico.Item(temp) = 1 Then mondico2(temp) = i
  Next
  Dim c()
  ReDim c(1 To mondico.Count, 1 To UBound(a, 2))
  ligne = 1
  For Each i In mondico2.items
     For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
     ligne = ligne + 1
  Next i
  Sheets("résultat").[A1].Resize(mondico.Count, UBound(a, 2)) = c
  Sheets("résultat").Select
End Sub

Suppression doublons en colonne

SupDoublonsColonne

Obtenir la liste des doublons et des uniques avec le filtre élaboré

Pour obtenir la liste des immatriculations en doublon

Le critère en M2 contient la formule: =NB.SI(BD!$A$2:$A$1000;BD!A2)>1

Sub Doublons()
  Sheets("BD").[A1:K1000].AdvancedFilter Action:=xlFilterCopy, _
     CriteriaRange:=[M1:M2], CopyToRange:=[A1:K1], Unique:=True
End Sub

FiltreElaboreUnique

Pour obtenir la liste des immatriculations uniques

Le critère en M2 contient la formule: =NB.SI(BD!$A$2:$A$1000;BD!A2)=1

Sub Uniques()
   Sheets("BD").[A1:K1000].AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=[M1:M2], CopyToRange:=[A1:K1], Unique:=False
End Sub

Suppression rapide des doublons de 2 listes

0,1 sec pour 10.000 lignes.

SupDoublonsColonneB

Sub sup()
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    If Not MonDico1.exists(c) Then MonDico1.Add c, c
  Next c
  b = Range("b2:b" & [b65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If Not MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2.Add c, c
  Next c
  [B2:B1000].ClearContents
  [b2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

Fonction SansDoublons

Fonction Sans Doublons
FonctionUnique
FiltreDynamique

Function SansDoublons(champ As Range)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In champ
    If Not mondico.Exists(c.Value) And c.Value <> "" Then mondico.Add c.Value, c.Value
  Next c
  SansDoublons = Application.Transpose(mondico.items)
End Function

Function SansDoublons2(champ As Range)
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In champ
     If Not mondico.Exists(c.Value) And c.Value <> "" Then mondico.Add c.Value, c.Value
   Next c
   Dim temp()
   ReDim temp(1 To champ.Count)
   i = 1
   For Each c In mondico.items
     temp(i) = c
      i = i + 1
   Next
   SansDoublons2 = Application.Transpose(temp)
End Function

Fonction SansDoublonsTrié

Pour 10.000 éléments, on obtient un temps de 0,15 sec (en matriciel pour 200 éléments, le temps est > 2sec)

Fonction Sans Doublons Trié

Function SansDoublonsTrié(champ As Range)
  Set mondico = CreateObject("Scripting.Dictionary")
  temp = champ
  For Each c In temp
    If c <> "" Then mondico(c) = ""
  Next c
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count)
  i = 1
  For Each c In mondico.keys
    b(i) = c
    i = i + 1
  Next
  Call tri(b, 1, mondico.Count)
  SansDoublonsTrié = Application.Transpose(b)
End Function

Sub tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Utilisation d'une fonction personalisée à partir de VBA

AppelFonctionSansDoublon

Sub Essai()
  [B2].Resize(UBound(SansDoublons([A2:A13]))) = SansDoublons([A2:A13])
  [F2].Resize(UBound(SansDoublons([E2:E13]))) = SansDoublons([E2:E13])
End Sub

Function SansDoublons(champ As Range)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In champ
      If c.Value <> "" Then mondico(c.Value) = c.Value
  Next c
  Dim temp()
  SansDoublons = Application.Transpose(mondico.items)
End Function

Eléments communs à 2 listes

Colorie les communs à 2 listes

ColorieCommuns
ColorieCommunsCoulDiff

Sub ColorieCommuns()
  Set f = Sheets("feuil1")
  Set a = f.Range("A2:A" & [A65000].End(xlUp).Row)
  Set b = f.Range("C2:C" & [C65000].End(xlUp).Row)
  b.Interior.ColorIndex = xlNone
  a.Interior.ColorIndex = xlNone
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In a
    MonDico1(c.Value) = c.Value
  Next c
  For Each c In b
    MonDico2(c.Value) = c.Value
    If MonDico1.exists(c.Value) Then c.Interior.ColorIndex = 3
  Next c
  For Each c In a
    If MonDico2.exists(c.Value) Then c.Interior.ColorIndex = 3
  Next c
End Sub

Comparaison des montants de 2 Bases de données

Pour 2 codes identiques dans les 2 BD, nous comparons si les montants sont différents.

Compare montant 2 BD
Compare codes 2 BD

Sub CompareMontant()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  f1.Range("A1:B10000").Sort Key1:=f1.[a2], Order1:=xlAscending, Header:=xlYes
  f2.Range("A1:B10000").Sort Key1:=f2.[a2], Order1:=xlAscending, Header:=xlYes
  Set a = f1.Range("A2:A" & f1.[a65000].End(xlUp).Row)
  Set b = f2.Range("a2:a" & f2.[a65000].End(xlUp).Row)
  b.Resize(, 2).Interior.ColorIndex = xlNone
  a.Resize(, 2).Interior.ColorIndex = xlNone
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In a
    d1(c.Value) = c.Offset(, 1).Value
  Next c
  For Each c In b
    d2(c.Value) = c.Offset(, 1).Value
    If d1.exists(c.Value) Then
       If d1.Item(c.Value) <> d2.Item(c.Value) Then c.Resize(, 2).Interior.ColorIndex = 3
    Else
      c.Resize(, 2).Interior.ColorIndex = 4
    End If
  Next c
  For Each c In a
    If d2.exists(c.Value) Then
      If d1.Item(c.Value) <> d2.Item(c.Value) Then c.Resize(, 2).Interior.ColorIndex = 3
    Else
      c.Resize(, 2).Interior.ColorIndex = 4
    End If
  Next c
End Sub

Comparaison avec MFC

On compare 2 listes de prix dans les colonnes A:B de de 2 feuilles BD1 et BD2

Compare_Prix

Noms de champ
Base1 ='BD1'!$A$2:$B$60
Base2 ='BD2'!$A$2:$B$58

Le produit existe t-il?: =ESTERREUR(RECHERCHEV($A2;Base2;1;FAUX)) ou =ESTERREUR(EQUIV($A2;INDEX(Base2;;1);0))
Le prix est-il différent?: =RECHERCHEV($A2;Base2;2;FAUX)<>$B2

Compare Prix acec MFC

Liste des communs à 2 listes - différence entre 2 listes

0,25 seconde pour 2 listes de 10.000 éléments.

Eléments Communs
Compare 2 Champs

Sub Communs()
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    If Not MonDico1.exists(c) Then MonDico1.Add c, c
  Next c
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2.Add c, c
  Next c
  [G2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

Sub Fusion()
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  For Each c In a
    If Not MonDico.exists(c) Then MonDico.Add c, c
  Next c
  For Each c In b
    If Not MonDico.exists(c) Then MonDico.Add c, c
  Next c
  [E2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.items)
End Sub

Sub Liste2_Liste1()
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    If Not MonDico1.exists(c) Then MonDico1.Add c, c
  Next c
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If Not MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2.Add c, c
  Next c
  [I2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

Sub Liste1_Liste2()
a = Range("C2:C" & [C65000].End(xlUp).Row)
Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each c In a
If Not MonDico1.exists(c) Then MonDico1.Add c, c
Next c
b = Range("A2:A" & [A65000].End(xlUp).Row)
Set MonDico2 = CreateObject("Scripting.Dictionary")
For Each c In b
If Not MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2.Add c, c
Next c
[K2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

Eléments communs à 2 listes avec 2 colonnes

Communs 2 listes

Sub Communs()
  Set f1 = Sheets("feuil1")
  Set f2 = Sheets("feuil2")
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("A2:A" & f1.[A65000].End(xlUp).Row)
    MonDico1(c & " " & c.Offset(, 1)) = ""
  Next c
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("A2:A" & f2.[A65000].End(xlUp).Row)
    tmp = c & " " & c.Offset(, 1)
    If MonDico1.exists(tmp) Then If Not MonDico2.exists(tmp) Then MonDico2(tmp) = ""
  Next c
  f2.[E2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub

Sur cette version, on récupère les informations des 2 feuilles

Communs 2 listes

Sub Communs()
  Set f1 = Sheets("feuil1")
  Set f2 = Sheets("feuil2")
  Set f3 = Sheets("feuil3")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("c1:c" & f1.[c65000].End(xlUp).Row) ' adapter
     mondico1(c & " " & c.Offset(, 1)) = c.Row
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("h1:h" & f2.[h65000].End(xlUp).Row) ' adapter
    tmp = c & " " & c.Offset(, 1)
    If mondico1.exists(tmp) Then If Not mondico2.exists(tmp) Then mondico2(tmp) = c.Row
  Next c
  f3.[A2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
  col1 = f1.[A1].CurrentRegion.Columns.Count ' adapter
  col2 = f2.[A1].CurrentRegion.Columns.Count ' adapter
  lig = 2
  For Each c In mondico2
    f1.Cells(mondico1(c), 1).Resize(, col1).Copy f3.Cells(lig, 2)
    f2.Cells(mondico2(c), 1).Resize(, col2).Copy f3.Cells(lig, col1 + 2)
  lig = lig + 1
  Next c
End Sub

Si les données sur feui1 ou feuil2 comportent des colonnes vides.

col1 = f1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
col2 = f2.Cells.Find("*", , , , xlByColumns, xlPrevious).Column

Communs avec filtre élaboré

En E2:=NB.SI($B$2:$B$10000;A2)>0

Communs

Sub communs()
 [A1:A10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:E2], CopyToRange:=[G1]
End Sub

Fonction liste différence triée entre 2 listes

FonctionListeDiffTriée

Function DiffTriée(a As Range, b As Range)
  Application.Volatile
  Dim temp()
  ReDim temp(1 To Application.Max(a.Count, b.Count))
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In b: mondico.Item(c) = c: Next c
  k = 0
  For Each c In a
    If c <> "" And Not mondico.exists(c) Then
      k = k + 1
      temp(k) = c
    End If
  Next c
  Call tri(temp, 1, k)
  DiffTriée = Application.Transpose(temp)
End Function

Sub tri(a(), gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Autre version

Function DiffTriée2(a As Range, b As Range)
  Dim temp()
  ReDim temp(1 To a.Count)
  k = 0
  For i = 1 To a.Count
    If IsError(Application.Match(a(i), b, 0)) And a(i) <> "" And a(i) <> 0 Then
      k = k + 1
      temp(k) = a(i)
    End If
  Next i
  Call tri(temp, 1, k)
  DiffTriée2 = Application.Transpose(temp)
End Function

Communs aux 2 listes

Function CommunsTriée(a As Range, b As Range)
  Application.Volatile
  Dim temp()
  ReDim temp(1 To Application.Max(a.Count, b.Count))
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In b: mondico.Item(c.Value) = c.Value: Next c
  k = 0
    For Each c In a
      If c.Value <> "" And mondico.exists(c.Value) Then
        k = k + 1
        temp(k) = c.Value
      End If
    Next c
    Call tri(temp, 1, k)
    CommunsTriée = Application.Transpose(temp)
End Function

Différence entre 2 BD

Cette méthode classique est peu rapide si les BD ont des tailles importantes.

Différence BD

Sub DiffBD1BD2()
  ligneEcrit = 2
  nblignes = Sheets("BD1").[A65000].End(xlUp).Row + 1
  For i = 2 To nblignes
    x = Sheets("BD1").Cells(i, 1)
    If IsError(Application.Match(x, Sheets("BD2").[A2:A1000], 0)) Then
       Cells(ligneEcrit, 1) = x
       ligneEcrit = ligneEcrit + 1
     End If
   Next i
  '---
  ligneEcrit = 2
  nblignes = Sheets("BD2").[A65000].End(xlUp).Row + 1
  For i = 2 To nblignes
    x = Sheets("BD2").Cells(i, 1)
    If IsError(Application.Match(x, Sheets("BD1").[A2:A1000], 0)) Then
      Cells(ligneEcrit, 2) = x
      ligneEcrit = ligneEcrit + 1
    End If
  Next i
End Sub

Méthode rapide

On veut la liste des clés de Base2 qui n'existent pas dans Base1.

Différence BD

Sub BD2_BD1()
  Set f1 = Sheets("Base1")
  Set f2 = Sheets("Base2")
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("a2:a" & f1.[a65000].End(xlUp).Row)
    MonDico1.Item(c.Value) = c.Value
  Next c
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("a2:a" & f2.[b65000].End(xlUp).Row)
    If Not MonDico1.exists(c.Value) Then
      If Not MonDico2.exists(c.Value) Then MonDico2.Add c.Value, c.Row
    End If
  Next c
  Sheets("Base2_Base1").[A2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
  Sheets("Base2_Base1").[b2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

Lignes qui existent dans BD1 et pas dans BD2

On recherche les lignes de BD1 qui n'existent pas dans BD2.
-La clé de comparaison est le nom.
-Certains noms ont des caractères accentués dans BD1 et pas dans BD2 (BDELHADI Lilià/BDELHADI Lilia).

Le fichier contient également la liste des Communs avec les infos des 2 BD

BDdiff

Sub BD1_nonBD2()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(b): mondico(UCase(sansAccent(b(i, 1)))) = "": Next i
    ligne = 1
    Dim c
    ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
    For i = 2 To UBound(a)
      If Not mondico.Exists(UCase(sansAccent(a(i, 1)))) Then
         For K = 1 To UBound(a, 2): c(ligne, K) = a(i, K): Next K
         ligne = ligne + 1
      End If
    Next i
    Sheets("BD1_BD2").[A2:C1000].ClearContents
    Sheets("BD1_BD2").[A2].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Function sansAccent(chaine)
  codeA = "ÉÈÊËÔéèêëàçùôûïî"
  codeB = "EEEEOeeeeacuouii"
  temp = chaine
  For i = 1 To Len(temp)
     p = InStr(codeA, Mid(temp, i, 1))
     If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
  Next
  sansAccent = temp
End Function

Comparaison de 2 listes avec quantités

CompareBDCmt
CompareBDEcart

Sub CompareBD1()
  Application.ScreenUpdating = False
  Set f1 = Sheets("Liste A")
  Set f2 = Sheets("Liste B")
  f2.[b:b].ClearComments
  f1.[b:b].ClearComments
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("A2:A" & f1.[A65000].End(xlUp).Row)
    mondico1(c.Value) = c.Offset(, 1).Value
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  '-- Liste B
  For Each c In f2.Range("A2:A" & f2.[A65000].End(xlUp).Row)
    mondico2(c.Value) = c.Offset(, 1).Value
    If mondico1.exists(c.Value) Then
      q = mondico1.Item(c.Value)
      If q <> c.Offset(, 1).Value Then
        c.Offset(, 1).AddComment
        c.Offset(, 1).Comment.Text Text:=CStr("Ecart:" & c.Offset(, 1) - q)
        c.Offset(, 1).Comment.Shape.TextFrame.AutoSize = True
        c.Offset(, 1).Comment.Visible = True
        c.Resize(, 2).Interior.ColorIndex = 33
      End If
    Else
       c.Resize(, 2).Interior.ColorIndex = 3
    End If
  Next c
End Sub

Comparaison de 2 BD par MFC

La clé est le nom.


BD compare

Contenu différent:

-Sélectionner A2:D20
-Format/Mise en forme conditionnelle/La formule est
=INDEX(MaBD2;EQUIV($A2;INDEX(MaBD2;;1);0);COLONNE())<>A2

Non trouvés dans BD1:

=ET(A2<>"";ESTNA(EQUIV($A2;INDEX(MaBD2;;1);0)))

Noms de champs
MaBD1 ='BD1'!$A$2:$D$100
MaBD2 ='BD2'!$A$2:$D$100

Lignes communes à 2 BD sur nom+prénom avec filtre élaboré

Formule du critère:
=SOMMEPROD(('BD2'!A2='BD1'!A1:A2000)*('BD2'!B2='BD1'!B1:B2000))>0

Sub ExtraitCommuns()
  Sheets("BD2").[A1:G2000].AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=[k1:k2], CopyToRange:=[A1:G1]
End Sub

Extrait Communs 2 BD

Pour la différence BD2-BD1, le critère devient

=SOMMEPROD(('BD2'!A2='BD1'!A1:A2000)*('BD2'!B2='BD1'!B1:B2000))=0

Lignes communes à 2 BD sur nom+prénom avec tableaux et dictionary

Sub communs()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a)
    temp = a(i, 1) & " " & a(i, 2)
    MonDico1(temp) = ""
  Next i
  ligne = 1
  Dim c
  ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
  For i = 2 To UBound(b)
    temp = b(i, 1) & " " & b(i, 2)
    If MonDico1.exists(temp) Then
      For k = 1 To UBound(b, 2): c(ligne, k) = b(i, k): Next k
        ligne = ligne + 1
     End If
   Next
   Sheets("communs").[A2].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Différence entre 2 BD sur nom+prénom avec tableaux et dictionary

Sub BD2_BD1()
Application.ScreenUpdating = False
Set f1 = Sheets("BD1")
Set f2 = Sheets("BD2")
a = f1.Range("A1").CurrentRegion.Value
b = f2.Range("A1").CurrentRegion.Value
Set MonDico1 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a)
temp = a(i, 1) & " " & a(i, 2)
MonDico1(temp) = ""
Next i
ligne = 1
Dim c
ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
For i = 2 To UBound(b)
temp = b(i, 1) & " " & b(i, 2)
If Not MonDico1.exists(temp) Then
For k = 1 To UBound(b, 2): c(ligne, k) = b(i, k): Next k
ligne = ligne + 1
End If
Next
Sheets("BD2_BD1").[A2].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Comparaison de 2 BD: Modifications, communs inchangés, ajouts, fusion

Des colonnes peuvent être ajoutées dans les BD sans modification du programme

CompareBD1
CompareBD2
CompareBD3
CompareBD4

Codes communs modifiés

On veut la liste des enregistrements modifiés dans l'onglet Base2 par rapport à l'onglet Base1.
Les champs modifiés sont coloriés en jaune.

Sub CommunsCode()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BASE 1")
  Set f2 = Sheets("BASE 2")
  Set f3 = Sheets("CommunsCode")
  f3.[A2:O1000].ClearContents
  f3.[A2:O1000].Interior.ColorIndex = xlNone
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value   
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For I = 2 To UBound(a)
    mondico2(a(I, 1)) = ""
  Next I
  ligne = 2
  For I = 2 To UBound(b)
    temp = ""
    For K = 1 To UBound(b, 2): temp = temp & b(I, K): Next K
    If mondico2.Exists(b(I, 1)) Then
      Set temp = f1.Columns(1).Find(b(I, 1))
      For K = 1 To UBound(b, 2)
         f3.Cells(ligne, K) = b(I, K)
         If b(I, K) <> temp.Offset(, K - 1) Then f3.Cells(ligne, K).Interior.ColorIndex = 6
      Next K
      f3.Cells(ligne, K) = I
      ligne = ligne + 1
    End If
  Next
End Sub

Ajouts dans Base2/Base1

Sub BD2_BD1()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BASE 1")
  Set f2 = Sheets("BASE 2")
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For I = 2 To UBound(a)
    mondico1(a(I, 1)) = ""
  Next I
  ligne = 1
  Dim c
  ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2) + 1)
  For I = 2 To UBound(b)
    temp = ""
    For K = 1 To UBound(b, 2): temp = temp & b(I, K): Next K
    If Not mondico1.Exists(b(I, 1)) Then
      For K = 1 To UBound(b, 2): c(ligne, K) = b(I, K): Next K
      c(ligne, K) = I
      ligne = ligne + 1
    End If
  Next
  Sheets("BD2 NON BD1").[a2].Resize(UBound(a, 1), UBound(a, 2) + 1) = c
End Sub

Communs inchangés sur toutes les colonnes

Sub CommunsInchangés()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BASE 1")
  Set f2 = Sheets("BASE 2")
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For I = 2 To UBound(a)
    temp = ""
    For K = 1 To UBound(a, 2): temp = temp & a(I, K): Next K
    mondico1(temp) = 1
  Next I
  ligne = 1
  Dim c
  ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
  For I = 1 To UBound(b)
    temp = ""
    For K = 1 To UBound(b, 2): temp = temp & b(I, K): Next K
    If mondico1.Exists(temp) Then
       For K = 1 To UBound(b, 2): c(ligne, K) = b(I, K): Next K
       ligne = ligne + 1
    End If
  Next
  Sheets("CommunsInchanges").[A1].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Autre exemple

On veut les codes SIRET communs aux 2 BD

CommunsBD

Sub Communs()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("e2:e" & f1.[e65000].End(xlUp).Row)
    mondico1.Item(c.Value) = c.Value
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("d2:d" & f2.[d65000].End(xlUp).Row)   
   If mondico1.Exists(c.Value) Then If Not mondico2.Exists(c.Value) Then mondico2.Add c.Value, c.Value
  Next c
  Sheets("communs").[A2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub

On veut les codes SIRET et les noms des entreprises:

Sub Communs2()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("e2:e" & f1.[e65000].End(xlUp).Row)
    mondico1.Item(c.Value) = c.Value
  Next c
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("d2:d" & f2.[d65000].End(xlUp).Row)
    If mondico1.Exists(c.Value) Then If Not mondico2.Exists(c.Value) Then mondico2.Add c.Value, c.Offset(, -3)
  Next c
  Sheets("communs").[A2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
  Sheets("communs").[B2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub

On veut la différence BD2-BD1:

Sub BD2_BD1()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("e2:e" & f1.[e65000].End(xlUp).Row)
    MonDico1.Item(c.Value) = c.Value
  Next c
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("d2:d" & f2.[d65000].End(xlUp).Row)
    If Not MonDico1.exists(c.Value) Then If Not MonDico2.exists(c.Value) Then MonDico2.Add c.Value, c.Offset(, -3)
  Next c
  Sheets("BD2_BD1").[A2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
  Sheets("BD2_BD1").[B2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.items)
End Sub

On veut la différence BD1-BD2:

Sub BD1_BD2()
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("d2:d" & f2.[d65000].End(xlUp).Row)
    MonDico2.Item(c.Value) = c.Value
  Next c
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("e2:e" & f1.[d65000].End(xlUp).Row)
   If Not MonDico2.exists(c.Value) Then If Not MonDico1.exists(c.Value) Then MonDico1.Add c.Value, c.Offset(, -4)
  Next c
  Sheets("BD1_BD2").[A2].Resize(MonDico1.Count, 1) = Application.Transpose(MonDico1.keys)
  Sheets("BD1_BD2").[B2].Resize(MonDico1.Count, 1) = Application.Transpose(MonDico1.items)
End Sub

Autre exemple de différence entre 2 BD

Cette méthode est rapide (<0,5 s pour 10.000 lignes).

DiffBD

Sub BD1_BD2()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  a = f2.Range("A1").CurrentRegion.Value
  b = f1.Range("A1").CurrentRegion.Value
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a): MonDico1(a(i, 1)) = 1: Next i
    ligne = 1
    Dim c
    ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
    For i = 1 To UBound(b)
      If Not MonDico1.exists(b(i, 1)) Then
        For k = 1 To UBound(b, 2): c(ligne, k) = b(i, k): Next k
        ligne = ligne + 1
      End If
    Next
    Sheets("BD1-BD2").[A2].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Lignes communes et différentes de 2 BD (sur toutes les colonnes)

Crée une BD avec les lignes communes à 2 BD (0,56 sec pour 10.000 lignes)

Communs2BD
BDDiff

Sub Communs()
   Application.ScreenUpdating = False
   Set f1 = Sheets("BD1")
   Set f2 = Sheets("BD2")
   a = f1.Range("A1").CurrentRegion.Value
   b = f2.Range("A1").CurrentRegion.Value
   Set MonDico1 = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(a)
     temp = ""
     For k = 1 To UBound(a, 2): temp = temp & a(i, k): Next k
     MonDico1(temp) = 1
   Next i
   ligne = 1
   Dim c
   ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
   For i = 1 To UBound(b)
     temp = ""
     For k = 1 To UBound(b, 2): temp = temp & b(i, k): Next k
        If MonDico1.exists(temp) Then
          For k = 1 To UBound(b, 2): c(ligne, k) = b(i, k): Next k
          ligne = ligne + 1
        End If
   Next
   Sheets("communs").[A1].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Différence BD1-BD2 sur toutes les colonnes

Sub BD1_BD2()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  a = f2.Range("A1").CurrentRegion.Value
  b = f1.Range("A1").CurrentRegion.Value
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    temp = ""
    For k = 1 To UBound(a, 2): temp = temp & a(i, k): Next k
    MonDico1(temp) = 1
  Next i
  ligne = 1
  Dim c
  ReDim c(1 To Application.Max(UBound(a), UBound(b)), 1 To UBound(a, 2))
  For i = 1 To UBound(b)
    temp = ""
    For k = 1 To UBound(b, 2): temp = temp & b(i, k): Next k
    If Not MonDico1.exists(temp) Then
      For k = 1 To UBound(b, 2): c(ligne, k) = b(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  Sheets("BD1_BD2").[A2].Resize(UBound(a, 1), UBound(a, 2)) = c
End Sub

Coloriage des communs

Communs2BDColoriage

Sub ColoriageCommuns()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a)
    temp = ""
    For k = 1 To UBound(a, 2): temp = temp & a(i, k): Next k
      mondico1(temp) = i
    Next i
    For i = 1 To UBound(b)
      temp = ""
      For k = 1 To UBound(b, 2): temp = temp & b(i, k): Next k
      If mondico1.exists(temp) Then
        f1.Cells(mondico1(temp), 1).Interior.ColorIndex = 4
        f2.Cells(i, 1).Interior.ColorIndex = 4
      End If
   Next
End Sub

Avec ADO

On veut les lignes communes à 2 BD d'un classeur fermé BDCommunsADO.xls.
Les BD sont nommées BDN1 et BDN2.

La requête SQL

SELECT * FROM BDN1,BDN2 WHERE bdn1.entreprise=bdn2.entreprise AND bdn1.cp=bdn2.cp AND   bdn1.code=bdn2.code AND bdn1.ville=bdn2.ville

Donne les lignes communes

Sub Communs()
  ' Microsoft ActiveX DataObject doit être coché
  ' les BD sont dans un autre classeur (BDCommunsADO.xls) sont nommées BDN1 et BDN2
  ' 1,5 sec pour 10.000 éléments
  repertoire = ThisWorkbook.Path
  Set cnn = New ADODB.Connection
  cnn.Open "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & repertoire & "\" & "BDCommunsADO.xls"
  Sql = "SELECT * FROM BDN1,BDN2 WHERE bdn1.entreprise=bdn2.entreprise AND bdn1.cp=bdn2.cp AND   bdn1.code=bdn2.code AND bdn1.ville=bdn2.ville "
  Set rs = cnn.Execute(Sql)
  tbl = rs.GetRows ' tableau à 2 dimensions on ne récupère pas la première ligne
  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
  [A2].Resize(UBound(tbl, 2) + 1, 4) = Application.Transpose(tbl)
End Sub

Coloriage des communs à 2 BD avec numéros de ligne

On veut colorier les communs sur toutes les colonnes.
On indique le no de ligne de l'autre feuille où le commun existe.
La méthode est rapide(0,3 s pour 10.000 lignes)

Communs

Sub ColoriageCommuns()
  ncol = 6       ' nombre de colonnes
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD1")
  Set f2 = Sheets("BD2")
  f1.Range("A1").CurrentRegion.Interior.ColorIndex = xlNone
  f2.Range("A1").CurrentRegion.Interior.ColorIndex = xlNone
  f1.Columns(ncol + 1).ClearContents
  f2.Columns(ncol + 1).ClearContents
  a = f1.Range("A1").CurrentRegion.Value
  b = f2.Range("A1").CurrentRegion.Value
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a)
     temp = ""
     For k = 1 To ncol: temp = temp & a(i, k): Next k
       mondico1(temp) = i
  Next i
  For i = 1 To UBound(b)
       temp = ""
       For k = 1 To ncol: temp = temp & b(i, k): Next k
         If mondico1.exists(temp) Then
            f1.Cells(mondico1(temp), 1).Resize(, 6).Interior.ColorIndex = 4
            f1.Cells(mondico1(temp), 7) = i 'mondico1(temp)
            f2.Cells(i, 1).Resize(, 6).Interior.ColorIndex = 4
            f2.Cells(i, 7) = mondico1(temp)
          End If
   Next
End Sub

Comparaison sur arrondi de champ numérique

ComparaisonArrondiNumérique
ComparaisonArrondiNumérique2

Eléments communs à plusieurs feuilles

CommunsPlusieursFeuilles

Sub communs()
  Set f1 = Sheets("10")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("a2:a" & f1.[a65000].End(xlUp).Row)
     mondico1.Item(c.Value) = c.Offset(, 1).Value
  Next
  For Each f In Array("15", "18", "12")
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In Sheets(f).Range("a2:a" & Sheets(f).[a65000].End(xlUp).Row)
      If mondico1.Exists(c.Value) Then mondico2(c.Value) = c.Offset(, 1).Value
    Next c
    Set mondico1 = mondico2
   Next f
   Sheets("communs").[c2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
   Sheets("communs").[d2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub

ou

Sub communs2()
  Set f1 = Sheets("10")
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("a2:a" & f1.[a65000].End(xlUp).Row)
    mondico1.Item(c.Value) = c.Offset(, 1).Value
  Next
  For Each f In Array("15", "18", "12")
    Set mondico2 = CreateObject("Scripting.Dictionary")
    a = Sheets(f).Range("a2:b" & Sheets(f).[a65000].End(xlUp).Row).Value
    For i = LBound(a) To UBound(a)
       If mondico1.Exists(a(i, 1)) Then mondico2(a(i, 1)) = a(i, 2)
    Next i
    Set mondico1 = mondico2
    Next f
    Sheets("communs").[c2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
    Sheets("communs").[d2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub

Fusion de 2BD

On veut obtenir la fusion de 2BD en éliminant les doublons.

Fusion2BD

Sub synthese()
  Set onglet1 = Sheets("BD1")
  Set onglet2 = Sheets("BD2")
  Sheets("recap").[A2:D10000].ClearContents
  Range(onglet1.[A2], onglet1.[A65000].End(xlUp).Offset(0, 2)).Copy Sheets("recap").[A2]
  For Each c In Range(onglet2.[A2], onglet2.[A65000].End(xlUp))
    p = Application.Match(c, [A:A], 0)
    If IsError(p) Then c.Resize(, 3).Copy [A65000].End(xlUp).Offset(1, 0)
  Next c
End Sub

Fusion sans doublons de BD

On fusionne plusieurs onglets en éliminant les doublons nom/prénom. FusionSansDoublons

Sub FusionSansDoublonsDictionary()
  [A2:C1000].ClearContents
  Application.ScreenUpdating = False
  For s = 2 To Sheets.Count ' Fusion
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy [A65000].End(xlUp).Offset(1, 0)
  Next s
  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  i = 2
  Do While Cells(i, "A") <> ""
    If Not MonDico.Exists(Cells(i, "A") & Cells(i, "B")) Then
       MonDico.Add Cells(i, "A") & Cells(i, "B"), 1
       i = i + 1
    Else
      Rows(i).EntireRow.Delete
    End If
  Loop
End Sub

Sub FusionSansDoublonsFiltreElaboré()
  [A2:C1000].ClearContents
  Application.ScreenUpdating = False
  For s = 2 To Sheets.Count ' fusion
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy [A65000].End(xlUp).Offset(1, 0)
  Next s
  [A1].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[b2], Order2:=xlAscending, Header:=xlGuess
  [G:G].Insert Shift:=xlToRight
  [G2].Formula = "=AND(A1=A2,B1=B2)"
  [A1:E1000].AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=[G1:G2]
  Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
  Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
  ActiveSheet.ShowAllData
  [G:G].Delete Shift:=xlToLeft
End Sub

Fusion/Consolidation de plusieurs BD rapide

On fusionne plusieurs onglets en éliminant les doublons nom/prénom et on additionne les montants des prestations. FusionConso

Sub FusionConso()
  [A2:C1000].ClearContents
  Application.ScreenUpdating = False
  For s = 2 To Sheets.Count               ' Fusion
    Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy [A65000].End(xlUp).Offset(1, 0)
  Next s
  [A1:C1000].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2], Order2:=xlAscending, Header:=xlGuess
  Set mondico = CreateObject("Scripting.Dictionary")
    For i = 2 To [A65000].End(xlUp).Row
      temp = Cells(i, "A") & "_" & Cells(i, "B")
      mondico(temp) = mondico(temp) + Cells(i, "C")
   Next
   [A2:C1000].ClearContents
   [A2].Resize(mondico.Count) = Application.Transpose(mondico.keys)
   [C2].Resize(mondico.Count) = Application.Transpose(mondico.items)
   Application.DisplayAlerts = False
   [A2:A1000].TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
     Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="_"
End Sub

Comparaison de 2 BD rapide (1 s pour 10.000 éléments)

Lorsque les références sont communes, l'écart entre entre les qte sont calculées.

ComparaisonBDEcart1
CompareBDEcart2

Sub CompareBD2()
   Application.ScreenUpdating = False
   Set f1 = Sheets("2008")
   Set f2 = Sheets("2009")
   Set f3 = Sheets("ecart")
   ligne = 1
   n1 = f1.Range("A65000").End(xlUp).Row
   n2 = f2.Range("A65000").End(xlUp).Row
   a = f1.Range("A2:D" & n1).Value
   b = f2.Range("A2:D" & n2).Value
   Set mondico1 = CreateObject("Scripting.Dictionary")
   For i = 1 To n1 - 1: mondico1.Add a(i, 1), i: Next
   Set mondico2 = CreateObject("Scripting.Dictionary")
   For i = 1 To n2 - 1: mondico2.Add b(i, 1), i: Next
   Dim c()
   [A2:L30000].ClearContents
  '--- communs
   For i = 1 To n1 - 1
      temp = a(i, 1)
      If mondico2.Exists(temp) Then
          p = mondico2.Item(temp)
          ReDim Preserve c(1 To 6, 1 To ligne)
          For k = 1 To 4: c(k, ligne) = a(i, k): Next k
          c(5, ligne) = b(p, 3) - a(i, 3)
          c(6, ligne) = "Communs"
          ligne = ligne + 1
       End If
    Next i
    '--- BD2-BD1
    For i = 1 To n2 - 1
      temp = b(i, 1)
      If Not mondico1.Exists(temp) Then
        p = mondico2.Item(temp)
        ReDim Preserve c(1 To 6, 1 To ligne)
        For k = 1 To 4: c(k, ligne) = b(i, k): Next k
        c(5, ligne) = b(p, 3)
        c(6, ligne) = f2.Name
        ligne = ligne + 1
      End If
    Next i
    '--- BD1-BD2
    For i = 1 To n1 - 1
      temp = a(i, 1)
      If Not mondico2.Exists(temp) Then
         p = mondico1.Item(temp)
         ReDim Preserve c(1 To 6, 1 To ligne)
         For k = 1 To 4: c(k, ligne) = a(i, k): Next k
         c(5, ligne) = -a(p, 3)
         c(6, ligne) = f1.Name
         ligne = ligne + 1
       End If
     Next i
     f3.[A2].Resize(ligne - 1, 6) = Application.Transpose(c)
End Sub

Autres exemples

Différence BD
Compare 2 BD
Fusion 2 Listes
Comparaison 2 BD
Comparaison 2BD

Compare les codes et les pays de 2 BD

Les codes et les pays doivent coïncider. Les pays ne sont pas écrits de la même façon dans les 2 BD(Voir table de correspondance des pays dans Traduction).

BDCompare5

Version MFC: BDCompareMFC

Sub compare()
  Set f1 = Sheets("File1")
  Set f2 = Sheets("File2")
  Set f3 = Sheets("Errors")
  ligne = 2
  f3.[A2:E100].ClearContents
  For i = 2 To f1.Range("d65000").End(xlUp).Row
    code = f1.Cells(i, "d")
    p = Application.Match(code, f2.[A:A], 0)
    If Not IsError(p) Then
      c1 = Trim(f1.Cells(i, "g"))
      c2 = Trim(f2.Cells(p, "f"))
      témoin = False
      For c = 1 To [country1].Count
        If UCase(Range("country1")(c)) = UCase(c1) And _
          UCase(Range("country2")(c)) = UCase(c2) Then témoin = True
      Next c
      If Not témoin Then
         f3.Cells(ligne, 1) = code
         f3.Cells(ligne, 2) = c1
         f3.Cells(ligne, 3) = c2
         ligne = ligne + 1
         f1.Cells(i, "d").Interior.ColorIndex = 4
         f2.Cells(p, "a").Interior.ColorIndex = 4
       End If
    Else
       f3.Cells(ligne, 1) = code
       f3.Cells(ligne, 2) = c1
       f3.Cells(ligne, 3) = "NC File2"
       ligne = ligne + 1
       f1.Cells(i, "d").Interior.ColorIndex = 3
     End If
  Next i
End Sub

Elimine les doublons à l'intérieur d'une cellule

Sans Doublons Cellule
Sans Doublons Cellule MAC

Function SansDoublon(c, sep)
  a = Split(Application.Trim(c), sep)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(a): mondico.Item(a(i)) = 1: Next i
  SansDoublon = Join(mondico.keys, sep)
End Function

Repérer les cellules qui contiennent 2 fois la même séquence à l'intérieur

Doublons Intérieur Cellules

MFC:=EstDoublon(A2)

Function EstDoublon(c)
  a = Split(Application.Trim(c), " ")
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(a): mondico.Item(a(i)) = 1: Next i
  EstDoublon = mondico.Count <> (UBound(a) + 1)
End Function

Effacer les cellules qui contiennent la même séquence dans un ordre différent

247 257 259 699 252
257 247 259 699 252

Sub supDoubles()
  derLig = 11
  '-- sup des cellules contenant des doublons à l'intérieur
  For Each c In Cells(2, 1).Resize(derLig)
    If EstDoublon(c) Then c.ClearContents
  Next
  '-- suppression des doublons entre cellules dans un ordre différent
  Set mondico1 = CreateObject("Scripting.Dictionary")
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For i = 2 To derLig
    If Cells(i, 1) <> "" Then
       temp = TriCell(Cells(i, 1))
       If Not mondico1.exists(temp) Then
          mondico1.Add temp, 1
          mondico2.Add Cells(i, 1), 1
       Else
          Cells(i, 1).ClearContents
       End If
     End If
   Next i
   [C2].Resize(mondico2.Count) = Application.Transpose(mondico2.keys)
End Sub

Function TriCell(cell)
  temp = Split(cell, " ")
  '---- tri
  For i = LBound(temp) To UBound(temp)
    For j = i To UBound(temp)
      If temp(j) < temp(i) Then
         temporary = temp(j)
         temp(j) = temp(i)
         temp(i) = temporary
       End If
     Next j
   Next i
   TriCell = Join(temp, " ")
End Function

Repérage de pseudo doublons

45003280 D est un doublon de 45003280
Cde 77560 B est un doublon de Cde 77560

Sub essai()
  [B:B].ClearContents
  [A:A].Interior.ColorIndex = xlNone
  For Each cel In [champ]
    Set c = [champ].Find(what:=cel, LookAt:=xlPart)
    If Not c Is Nothing Then
      premier = c.Address
      Do
        If cel.Value <> c.Value Then
          cel.Interior.ColorIndex = 8
          cel.Offset(, 1) = cel.Offset(, 1) & " Dbl de: " & c & " en " & c.Address
          c.Interior.ColorIndex = 36
        End If
        Set c = Range("champ").FindNext(c)
      Loop While Not c Is Nothing And c.Address <> premier
   End If
 Next cel
End Sub

Suppression de lignes vides

Cellules vides dans la colonne A

On Error Resume Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Cellules vides sur toutes les colonnes

For i = [A65000].End(xlUp).Row To 1 Step -1
  If Application.CountA(Rows(i)) = 0 Then  Rows(i).Delete
Next i

Cellules vides en colonne A(suppression rapide 0,28sec pour 10.000 lignes)

SupRapideVidesColonne A

Sub supLignesRapide()
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Cellules vides sur toutes les colonnes (suppression rapide 0,5sec pour 20.000 lignes)

SupRapideVidesToutesColonnes

Sub supLignesRapide()
  Application.ScreenUpdating = False
  n = [A65000].End(xlUp).Row
  Dim a()
  ReDim a(1 To n)
  For i = 2 To n
    If Application.CountA(Rows(i)) = 0 Then a(i) = "sup" Else a(i) = 0
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B1].Resize(n) = Application.Transpose(a) 
  [A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Cellules vides de la colonne A à la colonne H

SupLignesVidesColonne

Sub suplignesvides()
  Set f = Sheets("feuil1")
  Application.ScreenUpdating = False
  For i = f.[A65000].End(xlUp).Row To 2 Step -1
     If Application.CountA(Range(f.Cells(i, "b"), f.Cells(i, "h"))) = 0 Then f.Rows(i).Delete
  Next i
End Sub

Sub supLignesVides2()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1 = "=IF(COUNTA(RC[1]:RC[7])=0,""sup"",0)"
  Range("B2:B65000").SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
 Columns("b:b").Delete Shift:=xlToLeft
End Sub

En plaçant les lignes à supprimer à la fin, la suppression est beaucoup plus rapide

Sub supLignesVidesRapide()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1 = "=IF(COUNTA(RC[1]:RC[7])=0,""sup"",0)"
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Suppression des lignes et colonnes vides

For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
   If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
Next i
For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
   If Application.CountA(Columns(i)) = 0 Then Columns(i).Delete
Next i

Suppression de lignes

Suppression classique

On supprime les lignes qui contiennent xxxx dans la première colonne

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = [A65000].End(xlUp).Row To 1 Step -1
  If Cells(i, 1) = "xxxx" Then Rows(i).Delete Shift:=xlUp
Next i
Application.Calculation = xlCalculationAutomatic

      ou

[A:A].Replace "xxxx", ""
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

A l'aide d'une colonne intermédiaire

SupLignes

Sub supLignes()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1 = "=IF(RC[-1]=""xxxx"",""sup"",0)"
  Range("B2:B65000").SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Masquage

Sub MasqueLignes()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1 = "=IF(RC[-1]=""xxxx"",""sup"",0)"
  Range("B2:B65000").SpecialCells(xlCellTypeFormulas, 2).EntireRow.Hidden = True
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Suppression rapide

On regroupe les lignes à supprimer en fin de tableau.
La suppression des lignes ainsi regroupées en fin de tableau est très rapide.
L'ordre initial des lignes n'est pas modifié.

-on repère les lignes à supprimer avec la valeur Sup
-on tri les lignes . Les lignes contenant Sup se retrouvent à la fin
-on supprime les lignes contenant Sup

SupLignesRapide (0,2sec pour 20.000 lignes)

Sub supLignesRapide()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B2:B" & [A65000].End(xlUp).Row).FormulaR1C1 = "=IF(RC[-1]=""xxxx"",""sup"",0)"
  [B:B].Value = [B:B].Value
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Autre méthode (0,15 sec pour 20.000 lignes)

Sub supLignesRapide2()
  Application.ScreenUpdating = False
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "xxxx" Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Supprime les lignes qui contiennent Representative en colonne A

Application.ScreenUpdating = False
a = Range("A1:A" & [A65000].End(xlUp).Row)
For i = LBound(a) To UBound(a)
   If a(i, 1) Like "*Representative*" Then a(i, 1) = "sup" Else a(i, 1) = 0
Next i
Columns("b:b").Insert shift:=xlToRight
[B1].Resize(UBound(a)) = a
[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
On Error Resume Next
Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
Columns("b:b").Delete shift:=xlToLeft

Supprime les lignes qui contiennent 2011 en colonne Z (la présentation n'est pas conservée)

SupligneConditionTableau

Sub supLignesRapideTableau()
  Application.ScreenUpdating = False
  a = Range("A1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  For i = 1 To UBound(a)
    If a(i, 26) <> 2011 Then
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  [A1].Resize(ligne, UBound(a, 2)) = c
End Sub

Avec cette version, la présentation est conservée.

Sub supLignesRapidePrésentation()
  Application.ScreenUpdating = False
  a = Range("z2:z" & [z65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
      If a(i, 1) <> 2011 Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("aa:aa").Insert Shift:=xlToRight
  [aa2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("aa2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("aa2:aa65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("aa:aa").Delete Shift:=xlToLeft
End Sub

Suppression classique de lignes n'appartenant pas à une liste

Sup Lignes Liste

Sub supLignesListeClassique()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  Set f2 = Sheets("Liste")
  colCode = 5
  colListe = 1
  n = f2.Cells(65000, colListe).End(xlUp).Row
  Liste = f2.Cells(2, colListe).Resize(n - 1)
  For i = f1.Cells(Rows.Count, colCode).End(xlUp).Row To 2 Step -1
    c = Application.Match(f1.Cells(i, colCode), Liste, 0)
    If IsError(c) Then f1.Rows(i).Delete
  Next i
  Application.ScreenUpdating = True
End Sub

Sup Lignes Liste rapide

Sub supLignesListeRapide()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  Set f2 = Sheets("Liste")
  colcode = 5
  colListe = 1
  n = f2.Cells(65000, colListe).End(xlUp).Row
  liste = f2.Cells(2, colListe).Resize(n - 1)
  Set d = CreateObject("scripting.dictionary")
  For Each c In liste: d(c) = "": Next c
  n = f1.Cells(65000, colcode).End(xlUp).Row
  a = f1.Cells(2, colcode).Resize(n - 1)
  For i = LBound(a) To UBound(a)
    If d.exists(a(i, 1)) Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B2].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Suppression des lignes avec #N/A en colonne K

[k:k].SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete

Suppression de lignes avec le filtre automatique

SupLignesFiltreAuto

Sub SupLignesFiltreAuto()
   [A1].AutoFilter Field:=1, Criteria1:="xxxx"
   Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
      Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
   [A1].AutoFilter
End Sub

On veut supprimer les lignes dont les 5 premiers caractères appartiennent à l'ensemble 01517,01521,...

SupLignes

Sub supLignes()
  Application.ScreenUpdating = False
  Set Dico = CreateObject("Scripting.Dictionary")
  For Each c In Sheets("trie").[A1].CurrentRegion: Dico(c.Text) = "": Next c
  i = 1
  Set f = Sheets("BD")
    Do While f.Cells(i, 1) <> ""
       If Dico.Exists(Left(f.Cells(i, 1), 5)) Then f.Rows(i).Delete Else i = i + 1
    Loop
End Sub

Suppression avec le filtre élaboré

Supprime les exclus - xx yy zz - ( 0,1 S pour 10.000 lignes).
Au lieu de supprimer les lignes, on recopie dans une autre feuille ce qui ne doit pas être supprimé

SupLignesFiltre
SupLignesFiltre2

Sub sup_filtre()
  Sheets("result").[A:C].Clear
  Sheets("BD").Range("A1:C12000").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("BD").Range("F1:F2"), CopyToRange:=Sheets("result").Range("A1")
    Sheets("result").Select
End Sub

Fonction liste sans doublons triée multi-zones

-Sélectionner A2:A16
=ListeSDTriéeMZ((C6:C10;E5:E14;G5:G12))
-Valider avec maj+ctrl+entrée

FonctionSansDoublonsTriéeMultiZones
ListeSDTriéeMZ

Function ListeSDTriéeMZ(champ)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Areas.Count ' parcours des zones du champ multi-zones
    For j = 1 To champ.Areas(i).Count ' parcours des éléments d'une zone
      If champ.Areas(i)(j) <> "" Then
         temp = champ.Areas(i)(j)
         d.Item(temp) = ""     ' ajout au dictionnaire (doublons éliminés)
      End If
    Next j
  Next i
  temp = d.keys        'transfert dictionnaire dans une table temp()
  Call Tri(temp, LBound(temp), UBound(temp)) ' tri optionnel
  Dim b(): ReDim b(Application.Caller.Rows.Count)     ' table pour retour
  For i = LBound(temp) To UBound(temp): b(i) = temp(i): Next i
  ListeSDTriéeMZ = Application.Transpose(b)
End Function

Sub Tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      tmp = a(g): a(g) = a(d): a(d) = tmp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, g, droi)
  If gauc < d Then Call Tri(a, gauc, d)
End Sub

Repérage de doublons champ 3D avec MFC

MFC: =SOMMEPROD(--(NB.SI(INDIRECT("'"&nf&"'!A2:B10");A2)>0))>1

Doublons Champ 3D MFC
Doublons multi-colonnes 3D MFC
ColoriageDoublonsCommentMF
DoublonsMultiFeuilles
DoublonsMultiFeuilles2

Doublons d'un champ 3D+ doublons dans chaque champ avec MFC

=SOMMEPROD((--(NB.SI(INDIRECT("'"& nf &"'!A2:B10");A2)>0))+
(--(NB.SI(INDIRECT("'"& nf &"'!A2:B10");A2)>1)))>1

Doublons entre plusieurs champs avec MFC

MFC
=SOMMEPROD(--(NB.SI(INDIRECT(NomChamp);A2)>0))>1
ou
=SOMMEPROD(--(NB.SI(INDIRECT("champ"&LIGNE($1:$4));A2)>0))>1

Doublons multi-champ MFC

Suppression de doublons multi-feuilles

SupDoublonsMF
Fonction Sans Doublons Trié 3D
Fonction Sans Doublons Trié 3DBis

Private Sub Worksheet_Activate()
  Set mondico = CreateObject("Scripting.Dictionary")
  For s = [D1] To [D2]
    Set f = Sheets(s)
    For Each c In f.Range(f.Range("a2"), f.Range("a65000").End(xlUp))
      mondico(c.Value) = c.Value
    Next c
  Next s
  [A2:A65000].ClearContents
  [A2].Resize(mondico.Count) = Application.Transpose(mondico.items)
  [A:A].Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
End Sub

Autre exemple

SupDoublonsMF

Sub supDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
    For s = 1 To Sheets.Count - 1
      For Each c In Range(Sheets(s).[a2], Sheets(s).[a65000].End(xlUp))
         tmp = c & "*" & c.Offset(, 2)
         mondico(tmp) = tmp
      Next c
   Next s
   i = 2
   For Each c In mondico
    a = Split(c, "*")
    Sheets("synthèse").Cells(i, 1) = a(0)
    Sheets("synthèse").Cells(i, 2) = "'" & (a(1))
    i = i + 1
  Next c
End Sub

Liste des villes en doublons

ListeVillesEnDoublons

0,95 seconde pour 15.000 lignes et 300 doublons

Sub ListeVillesDoublons()
  Set f1 = Sheets("villes")
  Set f2 = Sheets("resultat")
  Set champ = f1.Range("A3:A" & f1.[A65000].End(xlUp).Row)
  Set mondico = CreateObject("Scripting.Dictionary")
  f2.[A1:F100].ClearContents
  For Each c In champ
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  ligne = 1
  For Each c In champ
    If mondico.Item(c.Value) > 1 Then
       c.Resize(, 6).Copy f2.Cells(ligne, 1)
       ligne = ligne + 1
    End If
  Next c
  f2.[A1].CurrentRegion.Sort Key1:=f2.[A1], Order1:=xlAscending, Header:=xlNo
End Sub

0,25 seconde pour 15.000 lignes et 300 doublons

Sub ListeVillesDoublonsRapide()
  Set f1 = Sheets("villes")
  Set f2 = Sheets("resultat")
  a = f1.Range("A3:F" & f1.[F65000].End(xlUp).Row).Value
  Set mondico = CreateObject("Scripting.Dictionary")
  f2.[A1:F100].ClearContents
  For i = 1 To UBound(a)
    mondico.Item(a(i, 1)) = mondico.Item(a(i, 1)) + 1
  Next i
  ligne = 1
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  For i = 1 To UBound(a)
    If mondico.Item(a(i, 1)) > 1 Then
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    End If
  Next i
  f2.[A1].Resize(mondico.Count, UBound(a, 2)) = c
  f2.[A1].CurrentRegion.Sort Key1:=f2.[A1], Order1:=xlAscending, Header:=xlNo
End Sub

Extraction des lignes en doublon sur les colonnes A+D+E

ExtractionDoublons

Nous utilisons le filtre élaboré. Le critère contient:

=SOMMEPROD((BD!$A$2:$A$1000=BD!A2)*(BD!$D$2:$D$1000=BD!D2)*(BD!$E$2:$E$1000=BD!E2))>1

Sub doublons()
  Sheets("BD").Range("A1:F30").AdvancedFilter Action:=xlFilterCopy, _
     CriteriaRange:=Sheets("Result").Range("I1:I2"), CopyToRange:=Sheets("Result").Range("A1:F1"),         Unique:=False
End Sub

Autre méthode avec Dictionary

Sub Doublons2()
  Set f1 = Sheets("bd")
  Set f2 = Sheets("result")
  Set champ = f1.Range("A2:A" & f1.[A65000].End(xlUp).Row)
  Set mondico = CreateObject("Scripting.Dictionary")
  f2.[A2:F100].ClearContents
  For Each c In champ
    temp = c.Value & c.Offset(, 3).Value & c.Offset(, 4).Value
    mondico.Item(temp) = mondico.Item(temp) + 1
  Next c
  ligne = 2
  For Each c In champ
    temp = c.Value & c.Offset(, 3).Value & c.Offset(, 4).Value
    If mondico.Item(temp) > 1 Then
      c.Resize(, 6).Copy f2.Cells(ligne, 1)
      ligne = ligne + 1
    End If
  Next c
  f2.[A1].CurrentRegion.Sort Key1:=f2.[A1], Order1:=xlAscending, Header:=xlYes
End Sub

Suppression de doublons avec totalisation

DoublonsSupTotalise
DoublonsSupTotalise2Colonnes

Sub DoublonsTotal()
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    d(c.Value) = d(c.Value) + c.Offset(, 1).Value
    d2(c.Value) = c.Offset(, 2)
  Next c
  [A2:C1000].ClearContents
  [a2].Resize(d.Count, 1) = Application.Transpose(d.keys)
  [b2].Resize(d.Count, 1) = Application.Transpose(d.items)
  [c2].Resize(d.Count, 1) = Application.Transpose(d2.items)
End Sub

Autre exemple

DoublonsSupTotalise2

Sub SupDoublonsColAColB()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    temp = a(i, 1) & a(i, 2)
    If Not mondico.exists(temp) Then
       mondico.Add temp, ""
       For k = 1 To UBound(a, 2) - 1: c(ligne, k) = a(i, k): Next k
       c(ligne, k) = c(ligne, k) + a(i, k)
       ligne = ligne + 1
    Else
       p = Application.Match(temp, mondico.keys, 0)
       col = UBound(a, 2)
       c(p, col) = c(p, col) + a(i, col)
    End If
  Next
  f1.[g1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

Autre exemple

SupDoublonsTotalisation
Totalisation avec condition

Sub SupDoublonsToutesColTotalisation()
  Application.ScreenUpdating = False
  Set f1 = Sheets("feuil1")
  a = f1.Range("A2").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    temp = ""
    For k = 1 To UBound(a, 2) - 1: temp = temp & a(i, k): Next
    If Not mondico.exists(temp) Then
      mondico.Add temp, ligne
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    Else
      lig = mondico.Item(temp)
      c(lig, UBound(a, 2)) = c(lig, UBound(a, 2)) + a(i, UBound(a, 2))
    End If
  Next
  f1.[H2].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

Nombre d'occurences des doublons

On veut classer les doublons par ordre du nombre d'occurences.

Occurences doublons

Sub DoublonsOccurence()
  a = Range("A2:H" & [A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(a) To UBound(a)
     d(CStr(a(i, 2))) = d(CStr(a(i, 2))) + 1
     a(i, UBound(a, 2)) = d(CStr(a(i, 2)))
  Next i
  Set f = Sheets("result")
  f.Cells.Clear: [A1:H1].Copy f.[A1]
  f.[a2].Resize(UBound(a), UBound(a, 2)) = a
  f.[a2].Sort key1:=f.[h2], key2:=f.[b2], Header:=yes
  For i = f.[A65000].End(xlUp).Row To 3 Step -1
     If f.Cells(i, 8) <> f.Cells(i - 1, 8) Then f.Rows(i).Insert
  Next i
  Set Rng = f.Range("A2:H" & f.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeConstants)
  For i = 1 To Rng.Areas.Count
    Rng.Areas(i).BorderAround Weight:=xlMedium
  Next i
End Sub

Fonction de suppression de doublons

Fonction suppression doublons BD

Génère des identifiants

Identifiant