Amélioration de mon code VBA

Bonjour,

je vais vous exposer ma situation. J'ai un code VBA qui me permet d'analyser deux plages de cellules et de recopier les mots identiques avec ses occurrences entre ces 2 plages. Exemple: Si le mot "Dans" est présent dans la première plage de cellule 5 fois et 1 fois dans la seconde, alors mon code va les recopier dans une plage de cellule. Le problème est que pour les mots aves des tirets, espace... ces derniers ne sont pas pris en compte. J'aimerai que mon code soit amélioré afin que si le mot composé existe séparément il soit recopié avec ses occurrences. Exemple: "Aissa-Slimani" est présent dans la première plage de cellule, mais dans le seconde il n'existe pas comme tel, mais "Aissa" et "Slimani" existe séparément. Dans ce cas précis je voudrais que "Aissa-Slimani" soit recopié avec son occurrence et l'occurrence de la deuxième plage de cellule. Voici mon code VBA:

Sub trouver_noms_identiques() ThisWorkbook.Worksheets("").Activate Dim rng1 As Range, rng2 As Range, c As Range Dim i As Long, j As Long, k As Long Dim n As Long Set rng1 = Range("A2:B5212") Set rng2 = Range("D2:E218983") k = 2 For i = 1 To rng1.Rows.Count For j = 1 To rng2.Rows.Count If rng1.Cells(i, 1).Value = rng2.Cells(j, 1).Value Then Range("H" & k).Value = rng1.Cells(i, 1).Value Range("I" & k).Value = rng1.Cells(i, 2).Value Range("J" & k).Value = rng2.Cells(j, 2).Value k = k + 1 Exit For End If Next j Next i End Sub.

bonjour,

merci à l'avenir de mettre ton code entre balise code (bouton </>)

une proposition

Sub trouver_noms_identiques()

    'ThisWorkbook.Worksheets("").Activate
    Dim rng1, rng2
    Dim i As Long, j As Long, k As Long, n As Long, dl1&, dl2&
    dl1 = Cells(Rows.Count, 1).End(xlUp).Row
    rng1 = Range("A2").Resize(dl1 - 1, 2)
    dl2 = Cells(Rows.Count, 4).End(xlUp).Row
    rng2 = Range("D2").Resize(dl2 - 1, 2)
    k = 2
    For i = LBound(rng1) To UBound(rng1)
        nom = LCase(Replace(rng1(i, 1), "-", " "))
        noms = Split(nom)
        For n = LBound(noms) To UBound(noms)
            For j = LBound(rng2) To UBound(rng2)
                If InStr(" " & noms(n) & " ", " " & LCase(rng2(j, 1)) & " ") > 0 Then
                    Range("H" & k).Value = rng1(i, 1)
                    Range("I" & k).Value = rng1(i, 2)
                    Range("J" & k).Value = rng2(j, 2)
                    k = k + 1
                    'n = UBound(noms) 'on s'arrête dès que l'on a trouvé une partie du mot
                    Exit For
                End If
            Next j
        Next n
    Next i
End Sub