XL 2016 travail sur tableau

Créer une discussion
Répondre

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 !

S'inscrire
F

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
 
Trier par date Trier par votes
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...
 

Pièces jointes

Vote positif 0 Vote négatif
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...
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
 
Vote positif 0 Vote négatif
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...
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 ?
 
Vote positif 0 Vote négatif
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...
Ok ! C'est clair ! Encore merci !
 
Vote positif 0 Vote négatif
bonsoir. J'ai revu un peu tout et nettoyer mes fichiers.. Laurent 950 'ai un pb avec la macro sur l'onglet "semblables". à la main, en comptant les "semblables" dans l'onglet solution, j'en ai une cinquantaine et la macro ne m'en donne que 11. Si tu pouvais m'aider pour clore ce sjet. e mets en fichiers joints le fichier avec les onglets et un fichier où premiere colonne on voit les 11 et deuxième colonne une liste plus conséquente. Merci si tu peux y jeter un dernier oeil...cordialement Robert
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour @finarobert

La solution se trouve dans ce post #51, via votre post #50 (ci-joint le code VBA ayant légèrement évolué).
finarobert à dit:
J'ai revu un peu tout et nettoyer mes fichiers
Cliquez pour agrandir...
Constat : la ligne 150 contient ni : ">sp" et "<c"
<1b2c3b212a2cb563520342bba82b547454211bb43ba5204241216b8502b46b8b515123312bc55b32c135ab2b35135c2b2bb3b53bb21b13cb2b042c3bb25cc14324647c4a0b32025a4430b4aa4
Alors ici dans le code
' Si c'est un mot
'Case Left(ligne.Value, 3) <> ">sp" And Left(ligne.Value, 2) <> "<c" ' A cause de la ligne 150 de votre fichier !
Case Left(ligne.Value, 1) <> ">" And Left(ligne.Value, 1) <> "<"
mot = Trim(ligne.Value)
reg.Pattern = mot

le code en relation avec votre fichier en poste #50

VB: 
Sub Programme1Ter_Semblables_Objets()

    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim lastRow As Long, outRow As Long
    Dim reg As Object, Matches As Object, Match As Object
    Dim ligne As Range
    Dim mot As String
 
    ' 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
    wsDst.Range("A1:D1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
    outRow = 2

    ' Déterminer la dernière ligne
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    ' Boucle sur toutes les lignes de la colonne A
    For Each ligne In wsSrc.Range("A1:A" & lastRow)
        Select Case True
            ' Si c'est un mot
            'Case Left(ligne.Value, 3) <> ">sp" And Left(ligne.Value, 2) <> "<c"
             Case Left(ligne.Value, 1) <> ">" And Left(ligne.Value, 1) <> "<"
                mot = Trim(ligne.Value)
                reg.Pattern = mot

            ' Si c'est une séquence <c> précédée d'un >sp
            Case ligne.Row > 2 And Left(ligne.Value, 2) = "<c" And Left(ligne.Offset(-1, 0).Value, 3) = ">sp"
                If reg.Pattern <> "" And reg.Test(ligne.Value) Then
                    Set Matches = reg.Execute(ligne.Value)

                    ' Mise en forme dans "solution"
                    For Each Match In Matches
                        With ligne.Characters(Match.FirstIndex + 1, Match.Length).Font
                            .Bold = True
                            .Name = "Calibri"
                            .Size = 14
                        End With
                    Next Match

                    ' Reporter si plus d'une occurrence
                    If Matches.Count > 1 Then
                        wsDst.Cells(outRow, 1).Value = mot
                        wsDst.Cells(outRow, 2).Value = ligne.Row - 1         ' n° ligne identité
                        wsDst.Cells(outRow, 3).Value = Matches.Count         ' Nombres
                        wsDst.Cells(outRow, 4).Value = ligne.Offset(-1, 0).Value ' Identité
                        outRow = outRow + 1

                        ' Mise en rouge
                        For Each Match In Matches
                            With ligne.Characters(Match.FirstIndex + 1, Match.Length).Font
                                .Bold = True
                                .Name = "Calibri"
                                .Size = 14
                                .Color = vbRed
                            End With
                        Next Match
                    End If
                End If
        End Select
    Next ligne

    MsgBox "Extraction terminée. " & outRow - 2 & " résultats trouvés.", vbInformation

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour @finarobert

Le code qui permet de detecter :
- la ligne 150 de votre fichier Excel "etape2vbacandidat2.xlsm" en Poste #50
<1b2c3b212a2cb563520342bba82b547454211bb43ba5204241216b8502b46b8b515123312bc55b32c135ab2b35135c2b2bb3b53bb21b13cb2b042c3bb25cc14324647c4a0b32025a4430b4aa4
Cliquez pour agrandir...
====================================================================================
Code 1 (Variante avec DICTIONARY)
Avec l'objet Scripting.Dictionary (Sans Module de classe associer au module standard : ExtraireObjetsSemblables_Dict)
Code: 
Sub ExtraireObjetsSemblables_Dict()

    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim ligneCell As Range
    Dim dict As Object
    Dim key As String

    ' Créer le dictionnaire
    Set dict = CreateObject("Scripting.Dictionary")

    ' Feuilles source et destination
    Set srcSheet = ThisWorkbook.Sheets("solution")
    On Error Resume Next
    Set destSheet = ThisWorkbook.Sheets("semblables")
    On Error GoTo 0
  
    If destSheet Is Nothing Then
        Set destSheet = ThisWorkbook.Sheets.Add
        destSheet.Name = "semblables"
    End If
  
    ' Nettoyage de la feuille destination
    destSheet.Cells.Clear
    destSheet.Range("A1:D1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
    outputRow = 2

    ' Dernière ligne de la colonne A
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row

    ' Remplir le dictionnaire
    For Each ligneCell In srcSheet.Range("A1:A" & lastRow)
        If Left(ligneCell.Value, 3) <> ">sp" And Left(ligneCell.Value, 2) <> "<c" Then
            key = CStr(ligneCell.Row)
            dict(key) = ligneCell.Value
        End If
    Next ligneCell

    ' Écrire les résultats
    Dim k As Variant
    For Each k In dict.Keys
        If Left(dict(k), 1) = ">" Or Left(dict(k), 1) = "<" Then
            destSheet.Cells(outputRow, 1).Value = dict(k)
            destSheet.Cells(outputRow, 2).Value = k
            outputRow = outputRow + 1
        End If
    Next k

    MsgBox "Extraction terminée. " & outputRow - 2 & " résultats trouvés.", vbInformation

End Sub
' ====================================================================================
Code 2 (Variante avec Collection + Module de Classe CItem)
Avec l'Objet Collection + Module de Classe CItem associer au (module standard : ExtraireObjetsSemblables)
Module de classe : CItem
Code: 
' Classe CItem
Public key As String
Public Valeur As Variant
module standard : ExtraireObjetsSemblables (associer : Module de Classe CItem)
Code: 
Sub ExtraireObjetsSemblables()

    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim ligneCell As Range
    Dim objItem As CItem
    Dim itemsCollection As Collection
    Dim elem As Variant

    ' Initialisation de la collection
    Set itemsCollection = New Collection
  
    ' Feuilles source et destination
    Set srcSheet = ThisWorkbook.Sheets("solution")
    On Error Resume Next
    Set destSheet = ThisWorkbook.Sheets("semblables")
    On Error GoTo 0
  
    If destSheet Is Nothing Then
        Set destSheet = ThisWorkbook.Sheets.Add
        destSheet.Name = "semblables"
    End If
  
    ' Effacer le contenu de la feuille destination
    destSheet.Cells.Clear
    destSheet.Range("A1:D1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
    outputRow = 2

    ' Déterminer la dernière ligne de la colonne A
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row

    ' Boucle pour remplir la collection avec les items
    For Each ligneCell In srcSheet.Range("A1:A" & lastRow)
        If Left(ligneCell.Value, 3) <> ">sp" And Left(ligneCell.Value, 2) <> "<c" Then
            Set objItem = New CItem
            objItem.Valeur = ligneCell.Value
            objItem.key = CStr(ligneCell.Row)
            itemsCollection.Add objItem
        End If
    Next ligneCell

    ' Boucle pour écrire les résultats dans la feuille destination
    For Each elem In itemsCollection
        Set objItem = elem
        If Left(objItem.Valeur, 1) = ">" Or Left(objItem.Valeur, 1) = "<" Then
            destSheet.Cells(outputRow, 1).Value = objItem.Valeur
            destSheet.Cells(outputRow, 2).Value = objItem.key
            outputRow = outputRow + 1
        End If
    Next elem

    MsgBox "Extraction terminée. " & outputRow - 2 & " résultats trouvés.", vbInformation

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
laurent950 à dit:
Bonjour @finarobert

Le code qui permet de detecter :
- la ligne 150 de votre fichier Excel "etape2vbacandidat2.xlsm" en Poste #50

====================================================================================
Code 1 (Variante avec DICTIONARY)
Avec l'objet Scripting.Dictionary (Sans Module de classe associer au module standard : ExtraireObjetsSemblables_Dict)
Code: 
Sub ExtraireObjetsSemblables_Dict()

    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim ligneCell As Range
    Dim dict As Object
    Dim key As String

    ' Créer le dictionnaire
    Set dict = CreateObject("Scripting.Dictionary")

    ' Feuilles source et destination
    Set srcSheet = ThisWorkbook.Sheets("solution")
    On Error Resume Next
    Set destSheet = ThisWorkbook.Sheets("semblables")
    On Error GoTo 0
 
    If destSheet Is Nothing Then
        Set destSheet = ThisWorkbook.Sheets.Add
        destSheet.Name = "semblables"
    End If
 
    ' Nettoyage de la feuille destination
    destSheet.Cells.Clear
    destSheet.Range("A1:D1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
    outputRow = 2

    ' Dernière ligne de la colonne A
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row

    ' Remplir le dictionnaire
    For Each ligneCell In srcSheet.Range("A1:A" & lastRow)
        If Left(ligneCell.Value, 3) <> ">sp" And Left(ligneCell.Value, 2) <> "<c" Then
            key = CStr(ligneCell.Row)
            dict(key) = ligneCell.Value
        End If
    Next ligneCell

    ' Écrire les résultats
    Dim k As Variant
    For Each k In dict.Keys
        If Left(dict(k), 1) = ">" Or Left(dict(k), 1) = "<" Then
            destSheet.Cells(outputRow, 1).Value = dict(k)
            destSheet.Cells(outputRow, 2).Value = k
            outputRow = outputRow + 1
        End If
    Next k

    MsgBox "Extraction terminée. " & outputRow - 2 & " résultats trouvés.", vbInformation

End Sub
' ====================================================================================
Code 2 (Variante avec Collection + Module de Classe CItem)
Avec l'Objet Collection + Module de Classe CItem associer au (module standard : ExtraireObjetsSemblables)
Module de classe : CItem
Code: 
' Classe CItem
Public key As String
Public Valeur As Variant
module standard : ExtraireObjetsSemblables (associer : Module de Classe CItem)
Code: 
Sub ExtraireObjetsSemblables()

    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim ligneCell As Range
    Dim objItem As CItem
    Dim itemsCollection As Collection
    Dim elem As Variant

    ' Initialisation de la collection
    Set itemsCollection = New Collection
 
    ' Feuilles source et destination
    Set srcSheet = ThisWorkbook.Sheets("solution")
    On Error Resume Next
    Set destSheet = ThisWorkbook.Sheets("semblables")
    On Error GoTo 0
 
    If destSheet Is Nothing Then
        Set destSheet = ThisWorkbook.Sheets.Add
        destSheet.Name = "semblables"
    End If
 
    ' Effacer le contenu de la feuille destination
    destSheet.Cells.Clear
    destSheet.Range("A1:D1").Value = Array("Mot", "N° ligne", "Nombre", "Identité")
    outputRow = 2

    ' Déterminer la dernière ligne de la colonne A
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row

    ' Boucle pour remplir la collection avec les items
    For Each ligneCell In srcSheet.Range("A1:A" & lastRow)
        If Left(ligneCell.Value, 3) <> ">sp" And Left(ligneCell.Value, 2) <> "<c" Then
            Set objItem = New CItem
            objItem.Valeur = ligneCell.Value
            objItem.key = CStr(ligneCell.Row)
            itemsCollection.Add objItem
        End If
    Next ligneCell

    ' Boucle pour écrire les résultats dans la feuille destination
    For Each elem In itemsCollection
        Set objItem = elem
        If Left(objItem.Valeur, 1) = ">" Or Left(objItem.Valeur, 1) = "<" Then
            destSheet.Cells(outputRow, 1).Value = objItem.Valeur
            destSheet.Cells(outputRow, 2).Value = objItem.key
            outputRow = outputRow + 1
        End If
    Next elem

    MsgBox "Extraction terminée. " & outputRow - 2 & " résultats trouvés.", vbInformation

End Sub
Cliquez pour agrandir...


Merci pour votre contribution, je vois que j'ai du boulot pour relever mon niveau !
cordialement
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

F
  • Question Question
XL 2016 recherche de mots
2
Réponses
19
Affichages
567
job75
job75
J
  • Question Question
XL 2019 Somme.si.ens sur deux listes par ligne
Réponses
5
Affichages
129
sylvanu
sylvanu
L
  • Résolu(e)
XL 2021 Recréer un tableau sur base de certaines données
Réponses
2
Affichages
723
Liowat
L
D
  • Question Question
Microsoft 365 Cas réel - avec problème complexe sur de la prevision de match en evitant les doublons
Réponses
1
Affichages
855
Dock91
D
F
  • Question Question
Microsoft 365 Recherche mot Excel avec copie sur un autre tableau
Réponses
5
Affichages
674
Fybu13
F
S
  • Résolu(e)
XL 2019 code vba changement de couleur si modification de la cellule
Réponses
7
Affichages
2 K
syriak
S
C
  • Résolu(e)
XL 2016 Novice VBA - Copier coller cellule non vide dans autre onglet
Réponses
13
Affichages
2 K
Robert
Robert
D
  • Question Question
XL 2016 Détecter des bugs en VBA
Réponses
2
Affichages
747
David1902
D
P
  • Question Question
XL 2016 [RESOLU] Additionner résultats de deux TCD
Réponses
6
Affichages
3 K
Poptar
P
J
  • Question Question
XL 2016 Création de macros diverses
Réponses
0
Affichages
1 K
Jérôme57
J
T
  • Question Question
XL 2016 Problème de conditions
Réponses
1
Affichages
1 K
nat54
nat54
A
  • Résolu(e)
XL 2019 Activer un onglet en fonction d'une variable // copier-coller sur une ligne vide mais à compter de la ligne 16
Réponses
5
Affichages
1 K
ALFM2021
A
D
  • Résolu(e)
Microsoft 365 UserForm remplit la textbox sélectionné
3 4 5
Réponses
66
Affichages
5 K
patricktoulon
patricktoulon
kinders59
  • Question Question
XL 2019 UserForm liste déroulante (cascade) avec ajout de données/modification
2 3
Réponses
38
Affichages
9 K
kinders59
kinders59
D
  • Question Question
Microsoft 365 Compléter un tableau de suivi automatiquement et bien compliqué :-)
Réponses
1
Affichages
2 K
herve62
herve62
K
  • Question Question
Microsoft 365 VBA - Bouton ne marche pas uniquement la première fois
Réponses
12
Affichages
2 K
mapomme
mapomme
C
  • Question Question
XL 2019 Colorier une lettre, un mot ou une phrase recherchée
5 6 7
Réponses
95
Affichages
7 K
patricktoulon
patricktoulon
D
  • Question Question
XL 2016 [RESOLU] plusieurs demandes VBA sur fichier de suivi de téléphones
Réponses
3
Affichages
1 K
dupuy.mathias
D
Gégé-45550
  • Résolu(e)
Microsoft 365 Tableau "fils" basé sur une colonne
Réponses
6
Affichages
1 K
Gégé-45550
Gégé-45550
P
  • Question Question
Microsoft 365 Comparaison de tableaux !
Réponses
1
Affichages
2 K
Patrosso
P
Retour