XL 2016 travail sur tableau

Sub Programme2Bis_Doublons_Regex_Mot()

    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim lastRow As Long, i As Long, outRow As Long
    Dim idCourant As String, ligneIdentite As String
    Dim dict As Object
    Dim ta As String, tb As String
    Dim arrKeys() As Variant, k As Long
    Dim tmp As Variant
    Dim currentMot As String
    Dim lignes() As String, idx As Long
    
    Dim reg As Object, Matches As Object, m As Object
    
    ' Feuilles
    Set wsSrc = ThisWorkbook.Sheets("solution")
    On Error Resume Next
    Set wsDst = ThisWorkbook.Sheets("doublons")
    On Error GoTo 0
    If wsDst Is Nothing Then
        Set wsDst = ThisWorkbook.Sheets.Add
        wsDst.Name = "doublons"
    End If
    
    ' Effacer l'onglet résultats
    wsDst.Cells.Clear
    wsDst.Range("A1:D1").Value = Array("Identifiant", "Le Mot", "N° ligne", "Texte identité")
    
    ' Dernière ligne de l'onglet solution
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    
    ' Initialiser dictionnaire
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Initialiser Regex
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Global = True
    
    currentMot = ""   ' mot courant provenant de la cellule numérique au-dessus des paquets
    
    ' Boucle sur toutes les lignes : on met à jour currentMot quand on rencontre un nombre,
    ' puis quand on rencontre >sp on utilise currentMot et la regex pour tester la ligne <c suivante.
    For i = 1 To lastRow
        Dim cellText As String
        cellText = CStr(wsSrc.Cells(i, 1).Value)
        
        ' Si on trouve une cellule numérique -> c'est le "mot" de contexte
        If IsNumeric(Trim(cellText)) Then
            currentMot = Trim(cellText)
            ' Mettre à jour le pattern regex (sans \b pour détecter 2726 collé)
            If Len(currentMot) > 0 Then
                reg.Pattern = currentMot
            Else
                reg.Pattern = ""    ' pas de motif
            End If
        
        ' Si on tombe sur une ligne identité >sp
        ElseIf Left(cellText, 3) = ">sp" Then
            ligneIdentite = cellText
            ta = Split(ligneIdentite, "|")(1)    ' ex: Q9UBK8.3
            tb = Split(ta, ".")(0)               ' ex: Q9UBK8
            If Len(tb) >= 2 Then
                idCourant = Mid(tb, 1, Len(tb) - 1)  ' ex: Q9UBK
            Else
                idCourant = tb
            End If
            
            ' Vérifier la ligne <c qui suit (si existante)
            If i + 1 <= lastRow Then
                Dim dataText As String
                dataText = CStr(wsSrc.Cells(i + 1, 1).Value)
                
                ' Si on a un pattern défini, tester la présence du mot dans la ligne <c
                If Len(currentMot) > 0 And reg.Pattern <> "" Then
                    If reg.Test(dataText) Then
                        ' Exécuter les matches et mettre en forme chaque occurrence
                        Set Matches = reg.Execute(dataText)
                        For Each m In Matches
                            ' m.FirstIndex est 0-based -> +1 pour Characters()
                            With wsSrc.Cells(i + 1, 1).Characters(m.FirstIndex + 1, Len(m.Value)).Font
                                .Bold = True
                                .Name = "Calibri"
                                .Size = 14
                                .Color = vbRed
                            End With
                        Next m
                    End If
                End If
            End If
            
            ' Stocker dans le dict : mot|ligne
            ' Si pas de mot courant, on stocke une chaîne vide pour la colonne "Le Mot"
            If currentMot = "" Then currentMot = ""
            
            If Not dict.Exists(idCourant) Then
                dict.Add idCourant, currentMot & "|" & i
            Else
                dict(idCourant) = dict(idCourant) & "," & currentMot & "|" & i
            End If
        End If
    Next i
    
    ' Copier les clés dans un tableau pour trier
    If dict.Count = 0 Then
        MsgBox "Aucun identifiant trouvé.", vbInformation
        Exit Sub
    End If
    arrKeys = dict.Keys
    
    ' Tri alphabétique simple (bubble sort)
    For i = LBound(arrKeys) To UBound(arrKeys) - 1
        For k = i + 1 To UBound(arrKeys)
            If arrKeys(i) > arrKeys(k) Then
                tmp = arrKeys(i)
                arrKeys(i) = arrKeys(k)
                arrKeys(k) = tmp
            End If
        Next k
    Next i
    
    ' Écriture dans la feuille doublons (seulement les clés avec plusieurs occurrences)
    outRow = 2
    For i = LBound(arrKeys) To UBound(arrKeys)
        If InStr(dict(arrKeys(i)), ",") > 0 Then
            lignes = Split(dict(arrKeys(i)), ",")
            For idx = LBound(lignes) To UBound(lignes)
                Dim parts() As String
                parts = Split(lignes(idx), "|")
                wsDst.Cells(outRow, 1).Value = arrKeys(i)                ' Identifiant
                wsDst.Cells(outRow, 2).Value = parts(0)                 ' Le Mot (peut être "")
                wsDst.Cells(outRow, 3).Value = CLng(parts(1))           ' N° ligne
                wsDst.Cells(outRow, 4).Value = wsSrc.Cells(CLng(parts(1)), 1).Value ' Texte identité
                outRow = outRow + 1
            Next idx
            outRow = outRow + 1 ' séparation entre groupes
        End If
    Next i
    
    MsgBox "Extraction doublons terminée. " & outRow - 2 & " lignes listées.", vbInformation

End Sub

If IsNumeric(Trim(wsSrc.Cells(i, 1).Value)) Then
mot = Trim(wsSrc.Cells(i, 1).Value)
reg.Pattern = mot

Sub Programme1Bis_Semblables_Regex()

Dim wsSrc As Worksheet, wsDst As Worksheet
Dim lastRow As Long, i As Long, outRow As Long
Dim mot As String

Dim reg As Object
Dim Matches As Object
Dim Match As Object

' Initialisation reg
Set reg = CreateObject("VBScript.RegExp")
reg.IgnoreCase = True
reg.Global = True

' Feuilles
Set wsSrc = ThisWorkbook.Sheets("solution")
On Error Resume Next
Set wsDst = ThisWorkbook.Sheets("semblables")
On Error GoTo 0
If wsDst Is Nothing Then
    Set wsDst = ThisWorkbook.Sheets.Add
    wsDst.Name = "semblables"
End If

' Effacer l'onglet résultats
wsDst.Cells.Clear

' Titres
wsDst.Range("A1:C1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
outRow = 2

' Dernière ligne de l'onglet solutions
lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

' Boucle sur les lignes de solutions
i = 1
Do While i <= lastRow
    ' Si c'est un mot (ni >sp ni >c)
    If Left(wsSrc.Cells(i, 1).Value, 3) <> ">sp" And Left(wsSrc.Cells(i, 1).Value, 2) <> "<c" Then
            ' Ici, pour le mot la ligne est <> ">sp" et <> "<c" on peut continuer
                mot = Trim(wsSrc.Cells(i, 1).Value)
            ' Construire le pattern reg avec délimiteurs de mots
                reg.Pattern = mot
    Else ' la ligne est commence par ">sp" et ou "<c" on peut continuer
        ' Avancer dans les paquets >sp + >c
        Do While i + 2 <= lastRow And Left(wsSrc.Cells(i + 1, 1).Value, 3) = ">sp" And Left(wsSrc.Cells(i + 2, 1).Value, 2) = "<c"
            ' Vérifier si la ligne >c contient le mot courant avec reg
            If reg.Test(wsSrc.Cells(i + 2, 1).Value) Then
               Set Matches = reg.Execute(wsSrc.Cells(i + 2, 1).Value)
               ' --- Mettre en forme le mot trouvé dans la feuille solution ---
                    For Each Match In Matches
                            With wsSrc.Cells(i + 2, 1).Characters(Match.FirstIndex + 1, Match.Length).Font
                                .Bold = True
                                .Name = "Calibri"
                                .Size = 14
                            End With
                    Next Match
             
               If Matches.Count > 1 Then
                ' Reporter dans l'onglet semblables
                    wsDst.Cells(outRow, 1).Value = mot
                    wsDst.Cells(outRow, 2).Value = i + 1                       ' n° ligne de l'identité
                    wsDst.Cells(outRow, 3).Value = Matches.Count                       ' Nombres
                    wsDst.Cells(outRow, 4).Value = wsSrc.Cells(i + 1, 1).Value ' texte identité
                    outRow = outRow + 1
                    ' ---------------------------------------------------------------
                    ' --- Mettre en forme le mot trouvé dans la feuille solution ---
                    For Each Match In Matches
                            With wsSrc.Cells(i + 2, 1).Characters(Match.FirstIndex + 1, Match.Length).Font
                                .Bold = True
                                .Name = "Calibri"
                                .Size = 14
                                .Color = vbRed
                            End With
                    Next Match
                    ' ---------------------------------------------------------------
                End If
            End If
            i = i + 2
        Loop
    End If
    i = i + 1
Loop
MsgBox "Extraction terminée. " & outRow - 2 & " résultats trouvés.", vbInformation
End Sub