XL 2016 travail sur tableau

[finarobert]

bonsoir
je cherche à faire deux programmes.
je possède un tableau excel avec 3 onglets : solutions, semblables et doublons (voir fichier joint)
l'onglet solutions est l'onglet de base et connu. Il n'y a que la première colonne d'alimenté. Comment est-elle construite?
Il y a des mots (voir 2726 en A1, 6746 en A184) et en dessous des paquets de 2 lignes avec la première ligne qui commence par >sp, c'est la ligne identité et une deuxième ligne qui commence par >c. Cette deuxième ligne porte les données de la ligne 1 qui comporte le mot en question (2726 en A1), on met alors ce mot en caractère gras.
onglet "semblables"
premier programme : on retrouve toutes les lignes identités qui ont au moins 2 mots dans leur ligne de données
deuxième programme : onglet doublons. Plus compliqué. le début de la ligne identité commence par une structure genre <sp IAb3DE.4 I. Deux identités sont considérés identiques sont sont considérés doublons lorsque les caractères voir exemple Ab3D sont identiques. On commence au premier caractère après la barre I et on finit à l'avant dernier caractère avant le point (D dans l'exemple)
merci pour le coup de main
Robert

 

[finarobert]

Au temps pour moi : j'ai oublié effectivement. Corrigé et suppression des lignes qui n'ont qu'une fois le mot.

Fichier modifié pour ces 2 aspects :

bonjour Chris, c'est parfait côté requete. je ferai les essai en vba et en requete, ce qui permettra un contr

Bonjour Laurent, peut-on rajouter à coté du numéro de ligne le "mot" auquel se rapporte l'identité?. Sinon tout est ok côté vba
Robert

ole et pour moi apprendre les requetes
merci pour tout
Robert

Bonjour Laurent, peut-on rajouter à coté du numéro de ligne le "mot" auquel se rapporte l'identité?. Sinon tout est ok côté vba
Robert

Laurent, encore moi. J'ai fait un essai avec un gros fichier mais 'ai l'impression pour l'onglet semblables que le programme es limité en nombre de mots. Je trouve 54 semblables alors que vba n'en trouve que 30. Il y a oar exemple QZN57.1 qui a 8 fois 1c3c alors que 1c3c n'apparait pas dans mon exemple. Idem pour les doublons 416 au lieu de 430 (j'ai fait à la main). Peut-on débloquer dans le vba ces barrages?
merci Laurent

 

[laurent950]

Bonjour Le Forum @finarobert

Bonjour Laurent, peut-on rajouter à coté du numéro de ligne le "mot" auquel se rapporte l'identité?. Sinon tout est ok côté vba
Robert

VBA avec votre fichier en Poste #1

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

 

[laurent950]

aurent, encore moi. J'ai fait un essai avec un gros fichier mais 'ai l'impression pour l'onglet semblables que le programme es limité en nombre de mots. Je trouve 54 semblables alors que vba n'en trouve que 30. Il y a oar exemple QZN57.1 qui a 8 fois 1c3c alors que 1c3c n'apparait pas dans mon exemple. Idem pour les doublons 416 au lieu de 430 (j'ai fait à la main). Peut-on débloquer dans le vba ces barrages?
merci Laurent

Dans mon code, le mot est pris uniquement si la cellule est numérique :

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

Les mots comme 1c3c → jamais pris en compte.
Les résultats « manquants » viennent probablement de là.

donc Modification
VBA avec votre fichier en Poste #1

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