XL 2016 travail sur tableau

Sub Programme1_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
        If IsNumeric(Trim(wsSrc.Cells(i, 1).Value)) Then
            ' Ici, mot est bien un nombre et on peut continuer
                mot = Trim(wsSrc.Cells(i, 1).Value)
            ' Construire le pattern reg avec délimiteurs de mots
                reg.Pattern = mot
        End If
      
        ' 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

Sub Programme2_Doublons()

    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
  
    ' 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:C1").Value = Array("Identifiant", "N° ligne", "Texte identité")
  
    ' Dernière ligne de l'onglet solutions
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
  
    ' Initialiser dictionnaire
    Set dict = CreateObject("Scripting.Dictionary")
  
    ' Boucle sur les lignes de solutions
    For i = 1 To lastRow
        If Left(wsSrc.Cells(i, 1).Value, 3) = ">sp" Then
            ligneIdentite = wsSrc.Cells(i, 1).Value
            ta = Split(ligneIdentite, "|")(1)
            tb = Split(ta, ".")(0)
            idCourant = Mid(tb, 1, Len(tb) - 1)
          
            If Not dict.Exists(idCourant) Then
                dict.Add idCourant, i
            Else
                ' Marquer les doublons en ajoutant l'index de ligne sous forme "X,Y,Z"
                dict(idCourant) = dict(idCourant) & "," & i
            End If
        End If
    Next i
  
    ' Copier les clés dans un tableau
    arrKeys = dict.Keys
  
    ' Tri alphabétique des clés (bubble sort pour simplicité)
    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
    outRow = 2
    For i = LBound(arrKeys) To UBound(arrKeys)
        If InStr(dict(arrKeys(i)), ",") > 0 Then
            ' Séparer les numéros de lignes regroupés
            Dim lignes() As String
            Dim idx As Long
            lignes = Split(dict(arrKeys(i)), ",")
          
            For idx = LBound(lignes) To UBound(lignes)
                wsDst.Cells(outRow, 1).Value = arrKeys(i)
                wsDst.Cells(outRow, 2).Value = lignes(idx)
                wsDst.Cells(outRow, 3).Value = wsSrc.Cells(CLng(lignes(idx)), 1).Value
                outRow = outRow + 1
            Next idx
            outRow = outRow + 1 ' ligne vide pour séparer les groupes
        End If
    Next i
  
    MsgBox "Extraction doublons terminée. " & outRow - 2 & " lignes listées.", vbInformation

End Sub