Discussion :

[keranLatos]

*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)

[Invité]

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.

[keranLatos]

d'accord merci je recheche cela alors

[keranLatos]

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

[Invité]

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.

[keranLatos]

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 !

[Invité]

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

[keranLatos]

j'allais justement me pencher sur le code merci beaucoup encore !

[keranLatos]

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 .

[keranLatos]

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

[Invité]

Un exemple de Selection.Find : https://www.developpez.net/forums/d2.../#post11440388

[keranLatos]

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

[keranLatos]

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 ^^'

[Invité]

Le dernier End With doit être après le Next I

[keranLatos]

je passe vraiment pour un idiot en faite ^^' xD desoler ^^". je vais essayer de comprendre tous cela ^^ merci

[keranLatos]

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

[Invité]

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.

[keranLatos]

j'etudie tous cela merci encore j'essaye de bien comprendre le tous mes connaissances sont encore bien legere .

[keranLatos]

Bah en 2 minute vous m'avez regler mon problème ^^' merci

[keranLatos]

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