Macro afficher message si valeurs identiques

[Sandrine123]

Bonjour,

Je souhaiterais faire une macro pour mon fichier test.xls.

Je voudrais qu'une fenetre msgbox s'affiche s'il y a 2 lignes identiques.

En fait, les 3 cellules qui doivent être scannées sont les colonnes P-Q-R.

J'aimerais que la macro détecte les doublons dans ces colonnes, cad, même date + même heure + CODE

Pouvez vous m'aider à faire cela ?

Merci d'avance.

Cordialement.

 

[st007]

Re : Macro afficher message si valeurs identiques

Bonjour,
on surligne la ligne des doublons
Executer macro "test" de pierrejean😉

 

[dra72]

Re : Macro afficher message si valeurs identiques

Bonjour Sandrine123, St007 et à tous,

Une autre possibilité.
Attention on utilise la colonne S. A modifier si cette colonne est déjà utilisée pour d'autres données.

Option Explicit

Dim Ra As Range
Dim Cell As Range
Dim I As Integer
Dim J As Integer
Dim DerLig As Integer
Dim X As String

Sub VerifDoublons()

  DerLig = Range("P" & Rows.Count).End(xlUp).Row
  Set Ra = Range("P2:P" & DerLig)
  
  For Each Cell In Ra
    Cell.Offset(0, 3) = Cell & Cell.Offset(0, 1) & Cell.Offset(0, 2)
  Next
  
  Set Ra = Range("S1:S" & DerLig)
  Ra.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  
  For I = 2 To DerLig
    If Rows(I).Hidden Then
      X = Range("S" & I)
      J = Ra.Find(What:=X, LookIn:=xlValues, LookAt _
          :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
          :=True).Row
      Rows(I).Hidden = False
      MsgBox "Doublon sur lignes " & J & " & " & I
    End If
  Next
  
  Ra.AdvancedFilter Action:=xlFilterInPlace, Unique:=False
  
  Columns(19).ClearContents
  
End Sub

Bonne journée

 

[Paf]

Re : Macro afficher message si valeurs identiques

bonjour à tous

une autre version, basique et sans doute moins rapide que celle de st007

Sub Sandrine123()
Dim i As Long, DerLig As Long
DerLig = Range("P" & Rows.Count).End(xlUp).Row
For i = 1 To DerLig
    If Range("P" & i).Value = Range("P" & i + 1).Value Then
        If Range("Q" & i).Value = Range("Q" & i + 1).Value Then
            If Range("R" & i).Value = Range("R" & i + 1).Value Then
                MsgBox "lignes  " & i & "  et  " & i + 1 & "   identiques"
            End If
        End If
    End If
Next
End Sub

et pour appliquer l'idée de st007du "coloriage" des lignes en défaut,on pourrait remplacer la ligne MsgBox... par

    Range("P" & i & ":R" & i + 1).Interior.ColorIndex = coul
    coul = coul + 1
    If coul > 56 Then coul = 3

en prenant soins de mettre en début de macro

Dim coul as byte
coul=3

bonne suite

 

[job75]

Re : Macro afficher message si valeurs identiques

Bonsoir Sandrine123, st007, dra72, Paf,

S'il s'agit de colorer des cellules, une macro n'est pas nécessaire.

Voyez le fichier joint avec le nom défini T et la MFC sur les colonnes P:R.

A+

 

[job75]

Re : Macro afficher message si valeurs identiques

Re,

Sur un tableau moyen (1000 lignes) la MFC ne pose pas de problème sur Excel 2003.

Sur un grand tableau (10000 lignes) problème avec la barre de défilement verticale.

A+

 

[job75]

Re : Macro afficher message si valeurs identiques

Bonjour le fil, le forum,

Avec de grands tableaux cette macro est une meilleure solution :

Sub MFC()
Dim tablo, ub&, mat() As Boolean, i&, t$, j&
tablo = Range("P1:R" & Range("P" & Rows.Count).End(xlUp).Row)
ub = UBound(tablo)
ReDim mat(1 To ub, 1 To 1)
For i = 1 To ub
  t = tablo(i, 1) & tablo(i, 2) & tablo(i, 3)
  For j = 1 To ub
    If i <> j And t = tablo(j, 1) & tablo(j, 2) & tablo(j, 3) _
      Then mat(i, 1) = True: Exit For
  Next
Next
ThisWorkbook.Names.Add "Matrice", mat 'nom défini
End Sub

La macro crée le nom défini Matrice utilisé dans la MFC.

Edit : la matrice doit être à 2 dimensions (vecteur vertical).

Fichier (2).

A+

 

[job75]

Re : Macro afficher message si valeurs identiques

Re,

Cette macro permet d'obtenir les lignes faisant doublons :

Sub Message()
If IsError([Matrice]) Then Exit Sub
Dim mat, i&, mes$
mat = [Matrice]
If UBound(mat) = 1 Then Exit Sub
For i = 1 To UBound(mat)
  If mat(i, 1) Then mes = mes & "-" & i
Next
MsgBox IIf(mes = "", "Aucun doublon", Mid(mes, 2)), , "Lignes des doublons"
End Sub

Fichier (3).

Edit : la MsgBox ne prend qu'un nombre limité de caractères (1023), si nécessaire éditer dans une cellule (32767 caractères).

A+

 

[job75]

Re : Macro afficher message si valeurs identiques

Re,

Testé sur Win XP - Excel 2003.

Avec un tableau de 1000 lignes sans doublon la macro MFC s'exécute en 2,1 secondes.

Avec un tableau de 10000 lignes on passe à 224 secondes (10^2 fois plus).

A+

 

[Sandrine123]

Re : Macro afficher message si valeurs identiques

Bonjour,

Merci à tous !! C'est parfait.

Effectivement très rapide job75.

Bonne journée.

 

[job75]

Re : Macro afficher message si valeurs identiques

Re,

Il fallait absolument réduire la durée d'exécution.

Cette nouvelle macro utilise la colonne auxiliare S et fait un tri sur les colonnes P Q R :

Sub MFC()
Dim P As Range, tablo, mat() As Boolean, i&
Set P = Range("P1:S" & Range("P" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
P(1, 4) = 1: P.Columns(4).DataSeries 'colonne S auxiliaire
P.Sort P(1), , P(1, 2), , , P(1, 3) 'tri sur les colonnes P Q R
tablo = P
ReDim mat(1 To UBound(tablo), 1 To 1)
For i = 1 To UBound(tablo) - 1
  If tablo(i, 1) & tablo(i, 2) & tablo(i, 3) = _
  tablo(i + 1, 1) & tablo(i + 1, 2) & tablo(i + 1, 3) _
  Then mat(tablo(i, 4), 1) = True: mat(tablo(i + 1, 4), 1) = True
Next
P.Sort P(1, 4), xlAscending, Header:=xlNo 'rétablit l'ordre initial
P.Columns(4).ClearContents 'RAZ
ThisWorkbook.Names.Add "Matrice", mat 'nom défini
End Sub

Il n'y a donc plus qu'une seule boucle.

Durée d'exécution sur 10000 lignes sans doublon : 0,20 seconde 😱

Edit : la boucle elle-même (traitement du tableau) ne prend que 0,03 seconde.

Fichier (4).

A+

 

[job75]

Re : Macro afficher message si valeurs identiques

Re,

Une variante bien meilleure :

Sub MFC()
Dim tablo, mat$(), d As Object, i&, t$
tablo = Range("P1:R" & Range("P" & Rows.Count).End(xlUp).Row)
ReDim mat(1 To UBound(tablo), 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
  t = tablo(i, 1) & tablo(i, 2) & tablo(i, 3)
  If d.exists(t) Then
    mat(i, 1) = d(t) & "-" & i: mat(d(t), 1) = "s"
  Else
    d(t) = i
  End If
Next
Application.ScreenUpdating = False 'facultatif
ThisWorkbook.Names.Add "Matrice", mat 'nom défini
End Sub

Sub Message()
If IsError([Matrice]) Then Exit Sub
Dim mat, t, mes$
mat = [Matrice]
If UBound(mat) = 1 Then Exit Sub
For Each t In mat
  If Val(t) Then mes = mes & " ; " & t
Next
MsgBox IIf(mes = "", "Aucun doublon", Mid(mes, 4)), , "Lignes des doublons"
End Sub

L'objet Dictionary permet de relier les doublons entre eux.

Comme il n'y a pas de tris, la macro MFC est plus rapide : 0,12 seconde sur 10000 lignes sans doublon.

Fichier (5).

A+