Discussion :

[nvincent]

Bonjour à tous et à toutes,

Je cherche une macro qui me permettrait d'identifier et de copier tous les paragraphes d'un document et de la placer dles uns à la suite des autres dans un nouveau document word (si possible en conservant les polices, couleurs, etc.)

Je ne m'y connais pas en programmation, est-ce que quelqu'un aurait ça sous le coude ?

Merci pour vos réponses

[nvincent]

Je viens de trouver, la réponse est ici :
http://www.developpez.net/forums/d60...doc-principal/

Il ne me reste plus qu'à tester maintenant !!..

[nvincent]

Bonjour à tous,

Je viens de tester la macro mais ça ne fonctionne pas
Je n'ai rien changer sauf à mettre un .docx à la place d'un .doc (j'utilise Word 2013), j'ai aussi mis en gras la ligne où la macro plante (avant ça aucun problème notamment sur la fonction "Appel"...

Voici le code :

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
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 = "D:\Doc\Essai\"
    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 "èf' I... FI, èn' i... NI c'est  FINI !"
End Sub

Sub Lister(Chemin$, LeMot$)
Dim NomFich$
Dim LeDoc As Document
    NomFich = Dir(Chemin & "*.docx") :D
    '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
 
            'Crée un lien hypertexte vers le document contenant le mot
            ThisDocument.Hyperlinks.Add Address:=Chemin & "\" & NomFich, _
                Anchor:=Selection.Range
        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

Quelqu'un a une idée ?..

[clementmarcotte]

Point d'arrêt : ==> Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
Espion : ==> Chemin & NomFich
Espion : ==> LeDoc
Lancer le débogage
une fois arrivé au point d'arrêt : F8

Si cela plante, il doit bien y avoir un message quelconque dans une InjureBox et la valeur de Ledoc et de Chemin & NomFich dans la fenêtre Espions

[nvincent]

Point d'arrêt : ==> Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
Espion : ==> Chemin & NomFich
F8

Si cela plante, il doit bien y avoir un message quelconque dans une InjureBox.

Salut,
En effet, j'ai : " Erreur d'exécution '424 : Objet requis "
Tu vois ce que ça peut être ?

[clementmarcotte]

Bonjour,

Visiblement, ton objet LeDoc ne peut pas être instancié.

Regarde dans ta fenêtre espion si ton chemin d'accès est complet. Il manque peut-être un "\"

sinon essaie avec cela:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Dim Fichier as string
fichier =Chemin & NomFich
Set LeDoc = appWd.Documents.Open(fichier)

si cela ne marche pas plus essaie avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Dim Fichier as string
fichier =Chemin & NomFich
Set LeDoc = appWd.Documents.Open filename:=fichier

Parce que si ton Word 2013 est comme mon Word 2010, il est capricieux avec les paramètres nommés

[nvincent]

Bonjour,

J'ai vérifié le chemin d'accès, il est correct donc RAS
J'ai ensuite essayé les 2 codes, le premier me renvoie la même erreur 424 et le second me met "erreur de syntaxe" avec la ligne Set LeDoc = appWd.Documents.Open filename:=fichier en rouge.
J'ai essayé de mettre un espion mais je n'y suis pas arrivé...

Par contre, la macro ouvre un nouvelle fenêtre word à chaque fois qu'elle est exécutée (avec l'erreur 424), mais chose étrange : la fenêtre ne comporte pas de document. Un peu comme si il ouvrait le programme Word, mais ne parvenais pas à créer un nouveau document à l'intérieur...
Ah ! Et aussi lorsque je veux fermer cette nouvelle fenêtre Word, il me met "Fichier utilisé par une autre application. (C:\User\...\Normal.dotm)

[Heureux-oli]

Salut,

Je n'ai pas écrit ce code, je n'utilise jamais le variables suivies d'un $.

Par contre, cette ligne : appWd.Visible = False cache l'instance de l'application, si le code plante en cours de route, l'appli reste ouverte et le normal.dot reste en utilisation.

Essaie l'exécution en pas à pas pour voir.
Pour le pas à pas, le plus simple est de mettre un point d'arrêt dans le code et ensuite faire F8 pour passer à l'étape suivante.

[nvincent]

Salut

je viens de faire tourner la macro en "pas à pas" avec un espion sur Chemin, NomFich, LeMot et LeDoc.

Ca plante toujours sur la ligne : Set LeDoc = appWD.Documents.Open(Chemin & NomFich)

Les valeurs pour LeMot, NomFich et Chemin sont toutes correctes :
LeMot est bien celui qui a été saisi
NomFich est bien le premier document Word qui se trouve dans le répertoire
Chemin indique bien la localisation du répertoire

Par contre il me met "Nothing" en valeur pour LeDoc.... Une idée ?

[Heureux-oli]

Salut,

Je pense que l'erreur vient de la concaténation du Chemin et du NomFich.

Dans le code, on a déjà un peu plus haut NomFich = Dir(Chemin & "*.docx"). Ce qui nous ferait deux fois Chemin dans le nom du fichier.

si tu regardes là, il y a une méthode un peu différente : http://heureuxoli.developpez.com/off...emplacer/#L3-B

[nvincent]

Salut,

Je pense que l'erreur vient de la concaténation du Chemin et du NomFich.

Dans le code, on a déjà un peu plus haut NomFich = Dir(Chemin & "*.docx"). Ce qui nous ferait deux fois Chemin dans le nom du fichier.

si tu regardes là, il y a une méthode un peu différente : http://heureuxoli.developpez.com/off...emplacer/#L3-B

Je n'ai pas programmé depuis des lustres, mais "dir(" renvoie une valeur, non ?

[Heureux-oli]

Salut,

Tu as raison, dir renvoie une valeur qui dans ton cas est le nom du fichier.
C'est une commande que je n'utilise pas.

Si le chemin et le nom du fichier sont corrects, je ne vois pas ce qui peut coincer dans l'ouverture du fichier.

[nvincent]

Bonjour à tous,

Voilà j'ai repris le code donné plus haut, mais ça ne fonctionne pas très bien :
- la macro tourne en boucle et ne s'arrête pas... Avec le débogage en pas à pas j'ai pu voir que la macro ne sort pas de la boucle " Do " et me copie en boucle le même paragraphe dans le doc cible...

Est-ce que quelqu'un pourrait me donner son avis ?

Partie du code suspecte :

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
        For Each oRw In oTbl1.Rows
            'Pour chaque mot, retour au début du document
            Selection.HomeKey Unit:=wdStory
            'boucle sur la recherche
            Do
                With Selection.Find
                    .Text = NetText(oRw.Cells(1).Range.Text)
                    .Execute
                    'Affectation du résultat de la recherche à une variable
                    boofound = .Found
                End With
                'si la recherche est fructueuse
                If boofound Then
                    'Insère un saut de ligne avant de coller le paragraphe
                    oDocCible.Range.InsertAfter vbCrLf
                    'renvoie en début de ligne
                    Selection.HomeKey Unit:=wdLine
                    'Sélectionne le paragraphe
                    Selection.StartOf Unit:=wdParagraph
                    Selection.MoveEnd Unit:=wdParagraph
 
                    'Copie le paragraphe
                    Selection.Copy
 
                   'Colle le paragraphe dans le document principal
                    oDocCible.Select
                    Selection.EndKey Unit:=wdStory
                    Selection.PasteAndFormat (wdPasteDefault)
 
                    'Insère un saut de ligne
                    oDocCible.Range.InsertAfter vbCrLf
 
                    oDocTrv.Select
 
                End If
 
            'test de sortie de boucle
            Loop While boofound
 
        Next oRw

Voici le code complet :

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
Sub Extraction()
'
' Extraction Macro
'
 
'Déclaration des variables
Dim oFso As FileSystemObject
Dim oFol As Folder
Dim oFil As File
Dim oDlg As FileDialog
Dim stFolder As String
Dim oDocSource, oDocTrv, oDocCible As Document
Dim oTbl1 As Table
Dim oRw As Row
Dim boofound As Boolean
 
'Affectation des variables
Set oFso = New FileSystemObject
Set oDlg = Application.FileDialog(msoFileDialogFolderPicker)
'Affichage de la boîte de dialogue
oDlg.Show
 
'Affectation du document contenant la liste
Set oDocSource = Documents.Open(FileName:="E:\Test Macro\listemots.docm")
 
'Affectation du document qui recevra le résultat de la recherche
Set oDocCible = Documents.Add
 
'Affectation de la table qui contient les mots à rechercher.
Set oTbl1 = oDocSource.Tables(1)
 
'Affectation du répertoire
Set oFol = oFso.GetFolder(oDlg.SelectedItems(1))
 
For Each oFil In oFol.Files
 
    'Test pour ne traiter que les documents et ignorer les autres fichiers
    If Right(oFil.Name, 4) = "docm" Or Right(oFil.Name, 4) = "docx" Or Right(oFil.Name, 3) = "doc" Then
        'ouverture des fichiers
        Set oDocTrv = Documents.Open(oFil.Path)
        'selection du fichier
        oDocTrv.Select
        'boucle sur la table contenant les mots
        For Each oRw In oTbl1.Rows
            'Pour chaque mot, retour au début du document
            Selection.HomeKey Unit:=wdStory
            'boucle sur la recherche
            Do
                With Selection.Find
                    .Text = NetText(oRw.Cells(1).Range.Text)
                    .Execute
                    'Affectation du résultat de la recherche à une variable
                    boofound = .Found
                End With
                'si la recherche est fructueuse
                If boofound Then
                    'Insère un saut de ligne avant de coller le paragraphe
                    oDocCible.Range.InsertAfter vbCrLf
                    'renvoie en début de ligne
                    Selection.HomeKey Unit:=wdLine
                    'Sélectionne le paragraphe
                    Selection.StartOf Unit:=wdParagraph
                    Selection.MoveEnd Unit:=wdParagraph
 
                    'Copie le paragraphe
                    Selection.Copy
 
                   'Colle le paragraphe dans le document principal
                    oDocCible.Select
                    Selection.EndKey Unit:=wdStory
                    Selection.PasteAndFormat (wdPasteDefault)
 
                    'Insère un saut de ligne
                    oDocCible.Range.InsertAfter vbCrLf
 
                    oDocTrv.Select
 
                End If
 
            'test de sortie de boucle
            Loop While boofound
 
        Next oRw
        'Fermeture du document dans lequel nous effectuons la recherche
        oDocTrv.Close
    End If
Next oFil
 
 
Set oTbl1 = Nothing
Set oTbl2 = Nothing
oDocSource.Close
Set oDocSource = Nothing
 
 
 
Set oDlg = Nothing
Set oFol = Nothing
Set oFso = Nothing
 
 
End Sub
 
 
Function NetText(stTemp As String) As String
'Fonction de nettoyage
'Supprime les deux derniers caractères de la cellule
NetText = Left(stTemp, Len(stTemp) - 2)
 
End Function

[Heureux-oli]

Salut,

Le tout est de savoir ce qui est recherché.
Normalement, le code du tuto fonctionne.

tu pourrais ajouter les paragraphes dans la table au lieu de la page et du nom du document.