VBA repérer des "doublons" sur la base du premier mot

Question

bonjour,

Je suis à la recherche d'un macro qui me permettrait de repérer des "doublons". Ce ne sont pas des doublons à proprement parler parce que les cellules peuvent ne pas être identiques. Par exemple "Volvo" et "Volvo SA" seront considérés comme des doublons.

J'ai trouvé cette macro qui marche super bien mais qui ne détecte que les doublons identiques.

Sub Doublons()
Dim Collec As New Collection, Cell As Range, Plage As Range

On Error Resume Next
Set Plage = Application.InputBox("Plage à examiner", Type:=8)
If IsEmpty(Plage) Then Exit Sub

For Each Cell In Plage
If Cell.Value <> "" Then
Collec.Add Cell.Value, CStr(Cell.Value)
If Err <> 0 Then
Err.Clear
Cell.Interior.ColorIndex = 3
Else
Cell.Interior.ColorIndex = 4
End If
End If
Next Cell
End Sub

L'idée serait de reprendre la même macro mais en améliorant celle-ci de sorte à ce que toutes les cellules ayant le même premier mot soient mis en rouge.

Quelqu'un pourrait-il me venir en aide pleaaase?

En vous remerciant d'avance.

Bien cordialement

florent · Answer

Je n'en suis pas sûr, mais essayer ceci :


Sub Doublons()
  Dim Collec As New Collection, Cell As Range, Plage As Range
  Dim chn As String, mot As String, p As Byte
  On Error Resume Next
  Set Plage = Application.InputBox("Plage à examiner", Type:=8)
  If IsEmpty(Plage) Then Exit Sub
  For Each Cell In Plage
    chn = CStr(Cell.Value): p = InStr(chn, " ")
    If p = 0 Then mot = chn Else mot = Left$(chn, p - 1)
    If chn <> "" Then
      Collec.Add mot, chn
      If Err <> 0 Then
        Err.Clear
        Cell.Interior.ColorIndex = 3
      Else
        Cell.Interior.ColorIndex = 4
      End If
    End If
  Next Cell
End Sub

Merci de m'indiquer si ça a marché ou non ;
si oui, tant mieux ; si non, pas d'autre idée.

VBA repérer des "doublons" sur la base du premier mot

1 réponse

Discussions similaires

Newsletters