XL 2016 travail sur tableau

finarobert à dit:

je n'arrive pas envoyer des infos car fichier trop volumineux
je découpe : réalité c'est le résultat attendu pour l'onglet
vba est le résultat de la macro et je vais découper le fichier de ase en deux fichiers point1 et point2

Cliquez pour agrandir...

laurent950 à dit:

Bonjour Le Forum @finarobert

VBA avec votre fichier en Poste #2

VB:

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
[/CODE
[/QUOTE]

Cliquez pour agrandir...

laurent950 à dit:

Bonjour Le Forum @finarobert

VBA avec votre fichier en Poste #2

VB:

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

Cliquez pour agrandir...

finarobert à dit:

je me rends compte que jje n'ai pas tenu compte de Poste#1 et Poste#2. Pouvez-vous me dire la différence?

Cliquez pour agrandir...

TooFatBoy à dit:

Quand on parle de "poste#1" ou "message #1" ou tout simplement "#1", ça correspond au premier message dans ce fil de discussion.
De même, "#2" correspond au deuxième message dans ce fil de discussion. Etc.
Si tu regardes en haut à droite de chaque réponse, tu verras inscrit le numéro du message. Celui-ci est le message #48.

Laurent parlait du fichier de ton message #1, mais il se trompait puisqu'il n'y a aucun fichier dans #1. Le fichier en question est dans #2.

Tout ceci est-il bien clair maintenant ?

Cliquez pour agrandir...