XL 2010 Extraction de contenu avec texte récurrent dans une ou plusieurs cellules Excel

Kajdrak · 25 Mars 2021

Bonjour,

Voici ma problématique, dans un tableau type ci-dessous, avec x lignes indéterminées, j'aimerais :

Extraire chaque "note de travail" (en "B" ici) (visiblement le terme "(notes de travail)" est celui qui revient, la date il ne faut pas s'y fier car on peut intégrer aussi une date dans la note...) des cellules.
Insérer un ligne pour chaque note reprenant le numéro de la ligne d'origine

Ainsi j'aurais pour x notes, x lignes avec le numéro associé à chaque ligne.
Et je ne m'en sort pas...! ^^'
Une bonne âme pour au moins m'aider à faire une macro fonctionnelle ?

Hasco · 26 Mars 2021

Bonjour,

Voici une proposition par macro. A vous d'adapter.

VB:

Sub ExtraireNotes()
'
    Dim Notes, Lignes, Textes                   ' Tableaux de valeurs
    Dim Num As String                           ' Numéro de la note en cours
    Dim iNote As Integer, iTexte As Integer     ' Compteurs de boucles

'
' Récupérer les textes de notes
    With ThisWorkbook.Sheets("Page 1").Range("A1").CurrentRegion
        Textes = .Offset(1).Resize(.Rows.Count - 1).Columns(13)
    End With
    '
    ' Parcourir la liste des textes
    For iTexte = 1 To UBound(Textes)
        '
        ' Récupérer le numéro du texte dans la feuille
        Num = ThisWorkbook.Sheets("Page 1").Cells(iTexte + 1, 1)
        '
        ' Eclater le texte par saut de ligne...

eastwick · 25 Mars 2021

Bonjour, un fichier serait plus qu'utile...

Kajdrak · 25 Mars 2021

Voici
Le colonne ne sont pas fixes, il peut y avoir du changement, mais au pire je m'adapterai en changeant la variable.

Dudu2 · 25 Mars 2021

@eastwick, le meilleur guitariste de Blues, aujourd'hui c'est Josh Smith

eastwick · 26 Mars 2021

Dudu2 à dit:
@eastwick, le meilleur guitariste de Blues, aujourd'hui c'est Josh Smith

Les goûts et les couleurs...

Hasco · 26 Mars 2021

Bonjour,

Voici une proposition par macro. A vous d'adapter.

VB:

Sub ExtraireNotes()
'
    Dim Notes, Lignes, Textes                   ' Tableaux de valeurs
    Dim Num As String                           ' Numéro de la note en cours
    Dim iNote As Integer, iTexte As Integer     ' Compteurs de boucles

'
' Récupérer les textes de notes
    With ThisWorkbook.Sheets("Page 1").Range("A1").CurrentRegion
        Textes = .Offset(1).Resize(.Rows.Count - 1).Columns(13)
    End With
    '
    ' Parcourir la liste des textes
    For iTexte = 1 To UBound(Textes)
        '
        ' Récupérer le numéro du texte dans la feuille
        Num = ThisWorkbook.Sheets("Page 1").Cells(iTexte + 1, 1)
        '
        ' Eclater le texte par saut de ligne
        Notes = Split(Textes(iTexte, 1), vbLf)   '
        '
        ' Parcourir le tableau résultant
        For iNote = 0 To UBound(Notes)
            '
            ' Pour chaque ligne finissant par "(Note de travail")
            If Right(Notes(iNote), 18) = "(Notes de travail)" Then
                '
                ' Rajouter un indicateur en début
                Notes(iNote) = "toto : " & Notes(iNote)
            End If
        Next iNote
        '
        ' Créer un nouveau tableau de notes
        ' comportant les items commençant par "Toto"
        Notes = Split(Join(Notes, vbLf), "toto : ")
        '
        ' Créer un tableau de lignes en conséquences
        ReDim Lignes(1 To UBound(Notes), 1 To 2)
        '
        ' Re parcourir le tableau de notes pour charger le tableau de lignes
        For iNote = 1 To UBound(Notes)
            If Notes(iNote) <> "" Then
                Lignes(iNote, 1) = Num
                ' Récupère la note en enlevant les retours à la ligne
                ' Peut-être prévoir un remplacement par espace ou simplement la note telle-quelle
                Lignes(iNote, 2) = Application.Clean(Notes(iNote))
            End If
        Next iNote
        '
        ' Le tableau de lignes dans la feuille
        ThisWorkbook.Sheets("Notes").Cells(Rows.Count, 1).End(xlUp)(1).Resize(UBound(Lignes), 2) = Lignes

    Next

End Sub

Cordialement

Kajdrak · 26 Mars 2021

Roblochon à dit:

Bonjour,

Voici une proposition par macro. A vous d'adapter.

VB:

Sub ExtraireNotes()
'
    Dim Notes, Lignes, Textes                   ' Tableaux de valeurs
    Dim Num As String                           ' Numéro de la note en cours
    Dim iNote As Integer, iTexte As Integer     ' Compteurs de boucles

'
' Récupérer les textes de notes
    With ThisWorkbook.Sheets("Page 1").Range("A1").CurrentRegion
        Textes = .Offset(1).Resize(.Rows.Count - 1).Columns(13)
    End With
    '
    ' Parcourir la liste des textes
    For iTexte = 1 To UBound(Textes)
        '
        ' Récupérer le numéro du texte dans la feuille
        Num = ThisWorkbook.Sheets("Page 1").Cells(iTexte + 1, 1)
        '
        ' Eclater le texte par saut de ligne
        Notes = Split(Textes(iTexte, 1), vbLf)   '
        '
        ' Parcourir le tableau résultant
        For iNote = 0 To UBound(Notes)
            '
            ' Pour chaque ligne finissant par "(Note de travail")
            If Right(Notes(iNote), 18) = "(Notes de travail)" Then
                '
                ' Rajouter un indicateur en début
                Notes(iNote) = "toto : " & Notes(iNote)
            End If
        Next iNote
        '
        ' Créer un nouveau tableau de notes
        ' comportant les items commençant par "Toto"
        Notes = Split(Join(Notes, vbLf), "toto : ")
        '
        ' Créer un tableau de lignes en conséquences
        ReDim Lignes(1 To UBound(Notes), 1 To 2)
        '
        ' Re parcourir le tableau de notes pour charger le tableau de lignes
        For iNote = 1 To UBound(Notes)
            If Notes(iNote) <> "" Then
                Lignes(iNote, 1) = Num
                ' Récupère la note en enlevant les retours à la ligne
                ' Peut-être prévoir un remplacement par espace ou simplement la note telle-quelle
                Lignes(iNote, 2) = Application.Clean(Notes(iNote))
            End If
        Next iNote
        '
        ' Le tableau de lignes dans la feuille
        ThisWorkbook.Sheets("Notes").Cells(Rows.Count, 1).End(xlUp)(1).Resize(UBound(Lignes), 2) = Lignes

    Next

End Sub

Cordialement

Je suis en train de vérifier, mais il me semble que cette réponse est parfaite !
Plus qu'à l'adapter effectivement en fonction de mes exports, mais vraiment, incroyable, merci !

Kajdrak · 26 Mars 2021

Roblochon à dit:

Bonjour,

Voici une proposition par macro. A vous d'adapter.

VB:

Sub ExtraireNotes()
'
    Dim Notes, Lignes, Textes                   ' Tableaux de valeurs
    Dim Num As String                           ' Numéro de la note en cours
    Dim iNote As Integer, iTexte As Integer     ' Compteurs de boucles

'
' Récupérer les textes de notes
    With ThisWorkbook.Sheets("Page 1").Range("A1").CurrentRegion
        Textes = .Offset(1).Resize(.Rows.Count - 1).Columns(13)
    End With
    '
    ' Parcourir la liste des textes
    For iTexte = 1 To UBound(Textes)
        '
        ' Récupérer le numéro du texte dans la feuille
        Num = ThisWorkbook.Sheets("Page 1").Cells(iTexte + 1, 1)
        '
        ' Eclater le texte par saut de ligne
        Notes = Split(Textes(iTexte, 1), vbLf)   '
        '
        ' Parcourir le tableau résultant
        For iNote = 0 To UBound(Notes)
            '
            ' Pour chaque ligne finissant par "(Note de travail")
            If Right(Notes(iNote), 18) = "(Notes de travail)" Then
                '
                ' Rajouter un indicateur en début
                Notes(iNote) = "toto : " & Notes(iNote)
            End If
        Next iNote
        '
        ' Créer un nouveau tableau de notes
        ' comportant les items commençant par "Toto"
        Notes = Split(Join(Notes, vbLf), "toto : ")
        '
        ' Créer un tableau de lignes en conséquences
        ReDim Lignes(1 To UBound(Notes), 1 To 2)
        '
        ' Re parcourir le tableau de notes pour charger le tableau de lignes
        For iNote = 1 To UBound(Notes)
            If Notes(iNote) <> "" Then
                Lignes(iNote, 1) = Num
                ' Récupère la note en enlevant les retours à la ligne
                ' Peut-être prévoir un remplacement par espace ou simplement la note telle-quelle
                Lignes(iNote, 2) = Application.Clean(Notes(iNote))
            End If
        Next iNote
        '
        ' Le tableau de lignes dans la feuille
        ThisWorkbook.Sheets("Notes").Cells(Rows.Count, 1).End(xlUp)(1).Resize(UBound(Lignes), 2) = Lignes

    Next

End Sub

Cordialement

Est-ce possible de fermer le sujet et le rendre invisible (sauf pour les admins du forum et celui ayant trouvé la solution éventuellement) : je me rend compte après coup que certains noms apparaissent par exemple, ou autres infos qui ne devraient pas être visible par un public. :/

Hasco · 26 Mars 2021

Re,

Je m'étais posé la question et ai oublié de vous le signaler

Non, mais vous pouvez rééditer votre post 1 et changer le classeur par un classeur anonymisé et sans données confidentielles.

Je rééditerai le mien pour faire en fonction du votre nouveau classeur.

Vous pouvez mettre en résolu votre discussion et choisir le post que vous souhaitez comme solution.

Cordialement

Kajdrak · 26 Mars 2021

Roblochon à dit:
Re,

Je m'étais posé la question et ai oublié de vous le signaler

Non, mais vous pouvez rééditer votre post 1 et changer le classeur par un classeur anonymisé et sans données confidentielles.

Je rééditerai le mien pour faire en fonction du votre nouveau classeur.

Vous pouvez mettre en résolu votre discussion et choisir le post que vous souhaitez comme solution.

Cordialement

Bon, tant pis... c'est pas vraiment confidentiel, surtout hors contexte
Alors choisir la solution c'est fait, mais mettre le topic en "Résolu".... Je vois pas ^^'

Hasco · 26 Mars 2021

Kajdrak à dit:
mettre le topic en "Résolu".... Je vois pas

vous l'avez fait en choisissant un post comme solution.

Bonne fin de semaine

XL 2010 Extraction de contenu avec texte récurrent dans une ou plusieurs cellules Excel

Kajdrak

XLDnaute Nouveau

Hasco

eastwick

XLDnaute Accro

Kajdrak

XLDnaute Nouveau

Pièces jointes

Dudu2

XLDnaute Barbatruc

eastwick

XLDnaute Accro

Hasco

XLDnaute Barbatruc

Pièces jointes

Kajdrak

XLDnaute Nouveau

Kajdrak

XLDnaute Nouveau

Hasco

XLDnaute Barbatruc

Kajdrak

XLDnaute Nouveau

Hasco

XLDnaute Barbatruc

Discussions similaires