XL 2016 travail sur tableau

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

finarobert

XLDnaute Occasionnel
Supporter XLD
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
 
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
 

Pièces jointes

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]

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
Bonsoit Laurent. Je reprends tout car je suis un peu paumé et je me rends compte que jje n'ai pas tenu compte de Poste#1 et Poste#2. Pouvez-vous me dire la différence?
merci Laurent
Robertt
 
je me rends compte que jje n'ai pas tenu compte de Poste#1 et Poste#2. Pouvez-vous me dire la différence?
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 ?
 
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 ?
Ok ! C'est clair ! Encore merci !
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
19
Affichages
561
Réponses
1
Affichages
2 K
Retour