Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Word Discussion :

REchercher et extraire


Sujet :

Word

  1. #1
    Membre à l'essai
    REchercher et extraire
    *Bonsoir ,
    je voudrais savoir si il etais possible de pouvoir rechercher et copier coller dans un nouveau dosier tous les phrase qui contienne un prenom que l'on choisi grace a un champs ? merci beaucoup (je vois pas encore comment mais je trouverais peu etre)

  2. #2
    Expert éminent sénior
    Citation Envoyé par keranLatos Voir le message

    Bonjour,

    Oui, c'est possible. Il suffirait d'instancier deux variables document DocSource et DocCible. Puis de créer une boucle sur la collection Sentences, voire Paragraphs du DocSource et à l'aide de la fonction Instr sélectionner les phrases ou les paragraphes contenant ce prénom, puis copier-coller dans un nouveau paragraphe dans DocCible.

    Une autre solution consisterait à faire la même chose mais depuis Excel (à la place du DocCible). L'avantage serait de structurer plus facilement les données et de mettre en place des liens hypertextes qui renverraient vers les différentes parties des documents analysés.
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  3. #3
    Membre à l'essai
    d'accord merci je recheche cela alors

  4. #4
    Membre à l'essai
    bonsoir ,Quelque chose comme cela ?

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    Option Explicit
    Private Const service As String = " 7/11 ans"
    Private Const Chef As String = "A y"
    Public DocEnCours As Document
    Public HeureArrêt As Date
    Public heure
    Sub rechercher()
    Dim texte As String, cherché As String
    Dim trouvé As Integer
    Dim Paragraphe As Word.Paragraph
     
    cherché = ActiveDocument.SelectContentControlsByTitle("Prénom")(1).Range.Text
    Documents("Transmission.docm").Activate
    For Each Paragraphe In ActiveDocument.Paragraphs
     
        Paragraphe.Select
        texte = Selection.Text
        trouvé = InStr(texte, cherché)
        Select Case trouvé
            Case Is > 0
                Selection.Copy
        Documents("document4").Active
        Selection.PasteAndFormat (wdFormatPlainText)
           Case Else
        End Select
    Selection.Collapse
     
    Next
    End Sub

  5. #5
    Expert éminent sénior
    Citation Envoyé par keranLatos Voir le message


    Le principe est bon, mais quelques problèmes de syntaxe notamment sur Paragraphe.Select, cela a dû sans doute foirer.
    Un exemple dans ce zip avec fichier Transmission en mode formulaire. Le fichier intéressant, c'est l'autre.
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  6. #6
    Membre à l'essai
    Bonjour deja merci encore et toujours pour votre aide grace a vous je comprend de mieux en mieux,
    votre archive est vraiment utile j'ai plus qu'a trouver comment faire pour ajouter ajouter un nouveau prenom dans le controle de contenue via un autre userform,et le coller dans le fichier d'ou je lance la vba et sa sera impeccable merci !

  7. #7
    Expert éminent sénior
    Citation Envoyé par keranLatos Voir le message

    j'ai plus qu'a trouver comment faire pour ajouter ajouter un nouveau prenom dans le controle de contenue via un autre userform,et le coller dans le fichier d'ou je lance la vba et sa sera impeccable merci !
    Testez ce code. Visiblement, l'ajout de prénoms est possible même en mode formulaire.
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
     
    Sub TestAjouterPrenom()
     
        AjouterPrenom "Michèle"
     
    End Sub
     
    Sub AjouterPrenom(ByVal PrenomAJouter As String)
     
    Dim Repertoire As String
    Dim DocSource As Document
    Dim ControlPrenom As ContentControl
    Dim J As Integer
     
        On Error GoTo Fin
     
        If FichierOuvert("Transmission.docm") = False Then
           MsgBox "Fichier Transmission non ouvert !", vbCritical
           GoTo Fin
        End If
     
        Continuer = False
        Set DocSource = Documents("Transmission.docm")
        With DocSource
             Repertoire = .Path
             If .ContentControls.Count > 0 Then
                For J = 1 To .ContentControls.Count
                    With .ContentControls(J)
                         If .Title = "Prénom" Then
                             .DropdownListEntries.Add Text:=PrenomAJouter, Value:=PrenomAJouter
                         End If
                    End With
                Next J
             End If
        End With
     
     
        GoTo Fin
     
     
    Fin:
     
       Application.ScreenUpdating = True
       Set DocSource = Nothing
     
    End Sub


    Sinon, l'ajout de prénoms peut poser un problème de lisibilité dans la ListBox du Userform. Le code ci-dessous fait le tri.
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
     
    Option Explicit
     
    Public Continuer As Boolean
    Public Cherche As String
     
     
    Sub TestRechercher2()
     
    Dim Repertoire As String
    Dim DocSource As Document, DocDestination As Document
    Dim ControlPrenom As ContentControl
    Dim J As Integer, K As Integer
    Dim StrTemp As Variant
     
        On Error GoTo Fin
     
        If FichierOuvert("Transmission.docm") = False Then
           MsgBox "Fichier Transmission non ouvert !", vbCritical
           GoTo Fin
        End If
     
        Continuer = False
        Set DocSource = Documents("Transmission.docm")
        With DocSource
             Repertoire = .Path
             If .ContentControls.Count > 0 Then
                For J = 1 To .ContentControls.Count
                    With .ContentControls(J)
                         If .Title = "Prénom" Then
                            For K = 1 To .DropdownListEntries.Count
                                UserFormRecherche.ListBoxPrenoms.AddItem .DropdownListEntries(K).Value
                            Next K
                         End If
                    End With
                Next J
             End If
        End With
     
        With UserFormRecherche
     
             'Tri le contenu de la ListBox par ordre alphabétique
            With .ListBoxPrenoms
                 For K = 0 To .ListCount - 1
                        For J = 0 To .ListCount - 1
                            If .List(K) < .List(J) Then
                                StrTemp = .List(K)
                                .List(K) = .List(J)
                                .List(J) = StrTemp
                            End If
                        Next J
                Next K
            End With
     
     
     
     
             .Show
        End With
     
        If Continuer = False Then GoTo Fin
     
        Application.ScreenUpdating = False
     
        Set DocDestination = Documents.Add
        DocDestination.SaveAs FileName:=Repertoire & "\" & Cherche & " " & Format(Now, "yyyy-mm-dd")  ' Format(Now, "yyyy-mm-dd hh-mm-ss")
     
        Rechercher2 DocSource, DocDestination, Cherche
     
        With DocDestination
             .Save
             .Activate
        End With
     
        GoTo Fin
     
     
    Fin:
     
       Application.ScreenUpdating = True
     
       Set DocSource = Nothing
       Set DocDestination = Nothing
     
     
     
    End Sub
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  8. #8
    Membre à l'essai
    j'allais justement me pencher sur le code merci beaucoup encore !

  9. #9
    Membre à l'essai
    je regarde tranquillement le code la , mais je me dit que je n'est peu être pas besoin de la car sa serais toujours le même nom que je cherche et que j’extraie .

  10. #10
    Membre à l'essai
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    Option Explicit
     
    Public appWd As Object
    Public LeDoc As Object
     
    Sub Appel()
    Dim Chemin$, Tablo As Variant, LeMot$
        Set appWd = CreateObject("Word.Application")
        appWd.Visible = False
        Chemin = "C:\Users\s\Desktop\"
        If Not Dir(Chemin) <> "" Then
            MsgBox "Répertoire inexistant"
            Exit Sub
        End If
        LeMot = InputBox("Saisir le mot à chercher", "RECHERCHE", "Le mot")
        CreateObject("Wscript.shell").Popup "Minute papillon, je bosse !", 1, "PATIENCE, ÇA VIENT !"
        If Trim(LeMot) <> "" Then
            Lister Chemin, LeMot
        End If
        appWd.Quit
        Set appWd = Nothing
        MsgBox "c'est  FINI !"
    End Sub
    Sub Lister(Chemin$, LeMot$)
    Dim NomFich$
    Dim LeDoc As Document
        NomFich = Dir(Chemin & "*.docx")
        'Vérification de l'existence de fichiers dans le répertoire
        If NomFich = "" Then
            MsgBox "Aucun fichier dans le répertoire " & Chemin
            Exit Sub
        End If
     
        'Ouverture des fichiers du répertoire
        Do While NomFich <> ""
            Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
            DoEvents
            'Lance la recherche
            If Chercher(LeMot) Then
                'Insère un saut de ligne avant de coller le paragraphe
                ThisDocument.Range.InsertAfter vbCrLf
                'renvoie en début de ligne
                appWd.Selection.HomeKey unit:=wdLine
     
                'Sélectionne le paragraphe
                appWd.Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
     
                'Copie le paragraphe
                appWd.Selection.Copy
     
                'Colle le paragraphe dans le document principal
                ThisDocument.Select
                Selection.EndKey unit:=wdStory
                Selection.PasteAndFormat (wdPasteDefault)
     
                'Insère un saut de ligne
                ThisDocument.Range.InsertAfter vbCrLf
     
            End If
     
            'Ferme le document objet de la recherche
            LeDoc.Close False
            Set LeDoc = Nothing
            DoEvents
     
            'Passe au fichier suivant
            NomFich = Dir
        Loop
    End Sub
    'Recherche du mot dans le fichier ouvert
    Function Chercher(LeMot$) As Boolean
        With appWd.Selection.Find
            .Text = LeMot
            Chercher = .Execute
        End With
    End Function


    Bonjour du coup j'ai trouver cela qui correspond mieux a ce que je cherche le seul hic que j'ai pour l'instant c'est que le fonction recherche ne copie pas tous les paragraphe comme la votre je vais essayer de comprendre merci

    Edit : c'est un probleme de boucle de paragraphe il suffit juste que j'arrive a lancer un for each paragraphe

  11. #11
    Expert éminent sénior
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  12. #12
    Membre à l'essai
    en faite j'ai editer un peu trop tard mon message d'avant le selection find merci je vais regarder car il faut aussi que je bosse sur une boucle for each paragraphe c'est la mon probleme

  13. #13
    Membre à l'essai
    j'ai essayer cela :
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    Sub recherche()
    Dim i As Integer
    Dim fichier As String, prenom As String
    fichier = Documents("Transmission journalière du lundi 23 novembre 2020.docx")
    prenom = ActiveDocument.SelectContentControlsByTitle("Prénom")(1).Range.Text
            With fichier
              For i = 1 To .Paragraphs.Count
                           .Paragraphs(i).Range.Select
     
                            With Selection.Find
                                .Text = prenom
                                .Forward = True
                                .Wrap = wdFindContinue
                            End With
            Selection.Expand unit:=wdParagraph
            Selection.Range.Copy
            End With
        Documents("Rechercher un nom dans un fichier.docm").Activate
        Selection.Range.Paste
    Next i
    End Sub


    mais j'ai un probleme avec le with ^^'

  14. #14
    Expert éminent sénior
    Citation Envoyé par keranLatos Voir le message

    Le dernier End With doit être après le Next I
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  15. #15
    Membre à l'essai
    je passe vraiment pour un idiot en faite ^^' xD desoler ^^". je vais essayer de comprendre tous cela ^^ merci

  16. #16
    Membre à l'essai
    Bon je pense que je doit etre encore loin de la bonne methode car il me copie tous le fichier et nom les paragraphe ou l'on trouve ""pierre" mais je vais trouver merci

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    Sub recherche()
    Dim i As Integer
    Dim fichier As String
    fichier = Documents("Transmission journalière du lundi 23 novembre 2020.docx")
    'prenom = ActiveDocument.SelectContentControlsByTitle("Prénom")(1).Range.Text
            With Documents("Transmission journalière du lundi 23 novembre 2020.docx")
              For i = 1 To .Paragraphs.Count
                           .Paragraphs(i).Range.Select
     
                            With Selection.Find
                                .Text = "pierre"
                                .Forward = True
                                .Wrap = wdFindContinue
                            End With
            Selection.Expand unit:=wdParagraph
            Selection.Range.Copy
     
        Documents("Rechercher un nom dans un fichier.docm").Activate
        Selection.Range.Paste
    Next i
    End With
    End Sub

  17. #17
    Expert éminent sénior
    Citation Envoyé par keranLatos Voir le message

    Je n'utilise que très peu Find, je lui préfère la commande Instr qui est tout à fait pertinente dans votre cas de figure. Voir ma réponse dans le fichier joint dans une précédente réponse.
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  18. #18
    Membre à l'essai
    j'etudie tous cela merci encore j'essaye de bien comprendre le tous mes connaissances sont encore bien legere .

  19. #19
    Membre à l'essai
    Bah en 2 minute vous m'avez regler mon problème ^^' merci

  20. #20
    Membre à l'essai
    il me manque plus que a faire en sorte que au lieux de prenom on choisi le texte dans le tableau la ligne 1 cell 2 et le dim file as string , file = document(teste)
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    Sub recherche()
    Dim i As Integer
    Dim fichier As String
    Dim prenom As String
    fichier = Documents("Transmission journalière du lundi 23 novembre 2020.docx")
    'prenom = ActiveDocument.SelectContentControlsByTitle("Prénom")(1).Range.Text
    On Error GoTo ErrorHandler
          With Documents("Transmission journalière du lundi 23 novembre 2020.docx")
               For i = 1 To .Paragraphs.Count
                   .Paragraphs(i).Range.Select
                   If InStr(1, Selection.Text, "pierre", vbTextCompare) > 0 Then
                      Selection.Copy
                      With Documents("Doc1.docm")
                           .Select
                           With Selection
                              .EndKey unit:=6
                              Selection.Range.Paste
                           End With
                      End With
                    End If
               Next i
         End With
               With Documents("Doc1.docm")
               For i = 1 To .Paragraphs.Count
                   .Paragraphs(i).Range.Select
                   If InStr(1, Selection.Text, "Présent", vbTextCompare) > 0 Then
                      Selection.Delete
                    End If
               Next i
         End With
    ErrorHandler:
    Exit Sub
    End Sub

###raw>template_hook.ano_emploi###