Sub RechercherDoublons()
Dim col, nbCells, i, j
col = ActiveCell.Column
nbCells = Application.WorksheetFunction.CountA(Range(Columns(col), Columns(col)))
For i = 1 To nbCells - 1
For j = i + 1 To nbCells
If Cells(i, col) = Cells(j, col) Then
Cells(j, col).Interior.Color = RGB(255, 0, 0)
End If
Next j
Next i
End Sub
Donc s'il y a des cellules vides dans la colonne, tu n'atteindras pas la dernière ligne.The COUNTA function counts the number of cells that are not empty in a range.
#Const TABLEAU_EST_TRIÉ = False
Sub RechercherDoublons()
Dim TabCol() As Variant
Dim NoColonne As Long
Dim NbLignes As Long
Dim i As Long
Dim j As Long
With ActiveSheet
NoColonne = ActiveCell.Column
'Aucune valeur dans la colonne
If Application.WorksheetFunction.CountA(.Columns(NoColonne)) = 0 Then
MsgBox "Aucune valeur dans cette colonne"
Exit Sub
End If
'Effacement de la colorisation précédente sur toute la colonne
With .Cells(1, NoColonne).Resize(Rows.Count).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
NbLignes = .Cells(Rows.Count, NoColonne).End(xlUp).Row
'Chargement de la colonne en table
TabCol = .Cells(1, NoColonne).Resize(NbLignes).Value
'Détection des doublons et colorisation
For i = 1 To UBound(TabCol, 1) - 1
If TabCol(i, 1) <> vbEmpty Then
For j = i + 1 To UBound(TabCol, 1)
If TabCol(j, 1) = TabCol(i, 1) Then
.Cells(j, NoColonne).Interior.Color = RGB(255, 0, 0)
#If TABLEAU_EST_TRIÉ Then
ElseIf TabCol(j, 1) > TabCol(i, 1) Then
Exit For
#End If
End If
Next j
End If
Next i
End With
End Sub
'Détection des doublons et colorisation
For i = LBound(TabCol, 1) To UBound(TabCol, 1) - 1
If TabCol(i, LBound(TabCol, 2)) <> vbEmpty Then
For j = i + 1 To UBound(TabCol, 1)
If TabCol(i, LBound(TabCol, 2)) = TabCol(j, LBound(TabCol, 2)) Then
.Cells(j, NoColonne).Interior.Color = RGB(255, 0, 0)
End If
Next j
End If
Next i
Je suis étonné que tu proposes ça. Le Dictionary est d'une lenteur sénatoriale.Utiliser une seule boucle avec le Dictionary, c'est archi classique, Dudu2 tu sais le faire.
Je suis étonné que tu ne connaisses pas les performances du Dictionary :Je suis étonné que tu proposes ça. Le Dictionary est d'une lenteur sénatoriale.
Sub Colorer_doublons()
Dim t, d As Object, tablo, i&, v$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Columns(1) 'colonne à adapter
.Interior.ColorIndex = xlNone 'RAZ
tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
v = CStr(tablo(i, 1))
If v <> "" Then
If d.exists(v) Then .Cells(i, 1).Interior.ColorIndex = 44 Else d(v) = ""
End If
Next
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \sec") 'mesure facultative
End Sub
Ah ben v'là ti aut'choseLe Dictionary est d'une lenteur sénatoriale.
Bah colorer les cellules prend du temps en VBA s'il y en a beaucoup à colorer.J'avais pris l'option de la MFC mais je préfère vraiment passer par VBA pour développer mes capacités.
Sub SansDico()
Dim derlig&, Source As Worksheet, wks As Object, nada, ok As Boolean, t, x, i&, ref, deb
deb = Timer
Set Source = ActiveSheet
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
derlig = Cells(Rows.Count, "a").End(xlUp).Row
Range("a1").Resize(derlig, 2).Interior.ColorIndex = xlColorIndexNone
t = Range("a1").Resize(derlig, 2)
For i = 1 To derlig: t(i, 2) = i: Next
On Error Resume Next
Set wks = ThisWorkbook.Worksheets.Add
If wks Is Nothing Then MsgBox "Erreur création feuille tempo => échec et fin!": Exit Sub
On Error GoTo Fin
With wks
.Range("a1").Resize(derlig, 2) = t
.Range("a1").Resize(derlig, 2).Sort key1:=.Columns(1), Header:=xlNo
t = .Range("a1").Resize(derlig, 2)
For i = 2 To derlig
If t(i, 1) = t(i - 1, 1) Then Source.Cells(t(i, 2), 1).Interior.Color = RGB(160, 241, 254)
Next i
End With
Application.DisplayAlerts = False: wks.Delete: Application.DisplayAlerts = True
Source.Cells(Rows.Count, "d").End(xlUp).Offset(1) = Format(Timer - deb, "0.00\ sec.")
Exit Sub
Fin:
Application.DisplayAlerts = False: wks.Delete: Application.DisplayAlerts = True
MsgBox "Erreur au sein de la macro => Echec!"
End Sub
Sub DoublonsEnMFC()
Dim Formule As String
Dim i As Integer
Dim t As Long
'
Const SupprimePrélablementToutesLesMFCDoublonsEnFeuille = True
'Const SupprimePrélablementToutesLesMFCDoublonsEnFeuille = False
Const ColorIndexDoublons = 44
Const FormuleDoublons = "=(NB.SI($%:$%;$%@)>1)*(LIGNE($%@)>EQUIV($%@;$%:$%;0))" 'Remplacer % par la lettre de la colonne concernée
'Remplacer @ par la 1ère ligne ou masque nombre E.R.
t = Timer
Application.ScreenUpdating = False
With ActiveSheet.Cells
If SupprimePrélablementToutesLesMFCDoublonsEnFeuille Then
'Suppression des MFC des doublons de toutes les colonnes
Formule = Replace(Replace(FormuleDoublons, "%", "?"), "@", "#*")
Else
'Suppression des MFC des doublons de la colonne active
Formule = Replace(Replace(FormuleDoublons, "%", LettreColonne(ActiveCell.Column)), "@", "#*")
End If
i = 1
Do While i <= .FormatConditions.Count
With .FormatConditions(i)
If .Type = 2 Then
If .Formula1 Like Formule Then
.Delete
i = i - 1
End If
End If
i = i + 1
End With
Loop
End With
'Ajout de la MFC des doublons sur la colonne active
With ActiveSheet.Columns(ActiveCell.Column).Cells
.FormatConditions.Add Type:=xlExpression, _
Formula1:=Replace(Replace(FormuleDoublons, "%", LettreColonne(ActiveCell.Column)), "@", "1")
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = ColorIndexDoublons
.FormatConditions(.FormatConditions.Count).StopIfTrue = False
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \sec") 'mesure facultative
End Sub
Function LettreColonne(NoColonne As Integer) As String
LettreColonne = Split(Cells(1, NoColonne).Address, "$")(1)
End Function