Récuperation paragraphe Word depuis ExCEL

F

fred19

XLDnaute Nouveau
bonjour ,

J'aimerai faire une macro capable de lire un fichier Word , mais de ne récuperer que certains paragraphes dont le style serait bien déterminé, puis de les coller dans excel en automatique.

Exemple :
Dans mon word plusieurs paragraphes
Paragraphe 1 (style début) ...bla bla ... (style FIN)
Paragraphe 2 (style autre) ... bla bla ... (style autre)
Paragraphe 3 (style début) ... bla bla ... (style FIN)

Dans excel j'aimerai récupérer les Paragraphe 1 et 3 qui commence par le style début et se termine avec le style fin.

J'ai trouvé des fragments de code mais aucun qui me permettent de choisir précisement mes paragraphes. Pouvez vous m'aider ?

j'ai deux solutions la premiere selectionne tout le contenu de word depuis excel mais j'arrive pas à filtrer par style de paragraphe

With AppWord

' On sélectionne tout
' .Selection.WholeStory
' On copie tout
' .Selection.Copy

La seconde lance une macro contenu dans word qui permet la selection par style :

'// Rechercher le texte de style "Identifiant"
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("ID_DBT") <== Style debut parag.
With Selection.Find
.Text = "^?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
While Selection.Find.Found
With Selection
.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
End With

'// On stocke le texte de l'identifiant
aIdentifiant = Trim(Selection.Text)
Selection.MoveRight Unit:=wdCharacter, Count:=2


While Selection.Paragraphs(Selection.Paragraphs.Count).Style <> "FIN" <== Style fin de selection
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Wend
Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend

ActiveDocument.Range(Start:=ActiveDocument.Tables(1).Cell(Row:=ActiveDocument.Tables(1).Rows.Count - 1, Column:=1).Range.Start, End:=ActiveDocument.Tables(1).Cell(Row:=ActiveDocument.Tables(1).Rows.Count - 1, Column:=1).Range.Start).InsertAfter aIdentifiant
ActiveDocument.Range(Start:=ActiveDocument.Tables(1).Cell(Row:=ActiveDocument.Tables(1).Rows.Count - 1, Column:=2).Range.Start, End:=ActiveDocument.Tables(1).Cell(Row:=ActiveDocument.Tables(1).Rows.Count - 1, Column:=2).Range.Start).InsertAfter Selection.Text
'// On ajoute une ligne pour le tableau
ActiveDocument.Tables(1).Rows.Add BeforeRow:=ActiveDocument.Tables(1).Rows(ActiveDocument.Tables(1).Rows.Count)

Selection.MoveDown Unit:=wdParagraph, Count:=1

Selection.Find.Style = ActiveDocument.Styles("ID_DBT")
With Selection.Find
.Text = "^?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Wend

Mais j'arrive pas à récuperer comme je le voudrai mes différents chapitres.

Please aidez moi
 
Dernière édition:
Trier par date Trier par votes
Hippolite

Hippolite

XLDnaute Accro
Re : Récuperation paragraphe Word depuis ExCEL

Bonjour,
Je n'ai pas eu le temps d'affiner, il reste un bug quand on exécute une deuxième fois la macro.
Comme je ne sais pas si j'aurai le temps demain, je donne quand même le code si ça peut te faire avancer :
VB: 
Public Sub Extraction()    '// Rechercher le texte de style "Identifiant"
'nécessite l'activation d'une référence Microsoft Word Object Library
'dans menu Outils/Références...
'    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim Fichier As String
    Dim Premier As Boolean
    Dim Debut1 As Long, Debut As Long, Fin, i As Long

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    Err.Clear

    'ouverture du fichier Word.doc placé dans le même répertoire que ce classeur excel
    Fichier = ThisWorkbook.Path & "\Sommaire.doc"
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Open(Fichier)

    Premier = True
    i = 1
    wdDoc.Activate
    Do
        With wdApp.Selection.Find    'Recherce du Style debut parag.
            .ClearFormatting
            .Style = ActiveDocument.Styles("ID_DBT Car")
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            If .Found = False Then Exit Do    ' Pas trouvé, on sort
        End With
        Debut = wdApp.Selection.Start   'Emplacement du début trouvé

        If Premier = True Then    'Mémorisation de la première occurrence trouvée
            Debut1 = wdApp.Selection.Start
            Premier = False
        Else
            If Debut = Debut1 Then Exit Do   'Le document a été totalement balayé, on sort
        End If

        wdApp.Selection.MoveRight , Count:=1    'Supprime la sélection  de la lettre trouvée
        With wdApp.Selection.Find    'Recherce du Style fin parag.
            .ClearFormatting
            .Style = ActiveDocument.Styles("FIN Car")
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            If .Found = False Then Exit Do    ' Pas trouvé, on sort
        End With
        Fin = wdApp.Selection.Start    'Emplacement de la fin trouvée
        Workbooks("Classeur1.xls").Sheets("Feuil1").Range("B" & 1 + i) = wdApp.ActiveDocument.Range(Debut, Fin)
        i = i + 1
        wdApp.Selection.MoveRight , Count:=1    'Supprime la sélection  de la lettre trouvée
    Loop
    wdApp.ActiveDocument.Close savechanges:=wdDoNotSaveChanges

    NombreDocsWordOuverts = wdApp.Documents.Count
    If NombreDocsWordOuverts = 0 Then
        wdApp.Quit
    End If
    Set wdApp = Nothing
End Sub
A+
 
Vote positif 0 Vote négatif
Hippolite

Hippolite

XLDnaute Accro
Re : Récuperation paragraphe Word depuis ExCEL

Bonjour,
Voilà le code finalisé :
VB: 
Public Sub Extraction()    '// Rechercher le texte de style "Identifiant"
'nécessite l'activation d'une référence Microsoft Word Object Library
'dans VBE menu Outils/Références...
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document, DOC As Word.Document
    Dim Chemin As String, Nom As String, Fichier As String
    Dim WordWasNotRunning As Boolean, wdDocWasNotOpen As Boolean, Premier As Boolean
    Dim Debut1 As Long, Debut As Long, Fin, i As Long
    
'Pramétrage du document Word
    Nom = "Sommaire.doc"
    Chemin = ThisWorkbook.Path & "\"
    
'Ouverture de l'application Word
    On Error Resume Next    ' Retarde la récupération d'erreur.
    ' La fonction Getobject appelée sans le premier
    ' argument renvoie une référence à une instance de
    ' l'application. Si l'application n'est pas en
    ' exécution, une erreur se produit.
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then    ' création d'une instance Word
        Set wdApp = CreateObject("Word.Application")
        WordWasNotRunning = True
    End If
    Err.Clear
    On Error GoTo 0
    
'Ouverture du document Word
    wdDocWasNotOpen = True
    For Each DOC In wdApp.Documents   'Détecte si le document Word est déjà ouvert
        If DOC.Name = Nom Then
            wdDocWasNotOpen = False
            Exit For
        End If
    Next DOC
    Set wdDoc = GetObject(Chemin & Nom)    'Renvoie une référence au document Word

'Extraction
    Premier = True
    i = 1
    wdDoc.Select
    wdApp.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Do
        With wdApp.Selection.Find    'Recherce du Style debut parag.
            .ClearFormatting
            .Style = wdApp.ActiveDocument.Styles("ID_DBT Car")
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            If .Found = False Then Exit Do    ' Pas trouvé, on sort
        End With
        Debut = wdApp.Selection.Start   'Emplacement du début trouvé

        If Premier = True Then    'Mémorisation de la première occurrence trouvée
            Debut1 = wdApp.Selection.Start
            Premier = False
        Else
            If Debut = Debut1 Then Exit Do   'Le document a été totalement balayé, on sort
        End If

        wdApp.Selection.MoveRight , Count:=1    'Supprime la sélection  de la lettre trouvée
        With wdApp.Selection.Find    'Recherce du Style fin parag.
            .ClearFormatting
            .Style = wdApp.ActiveDocument.Styles("FIN Car")
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            If .Found = False Then Exit Do    ' Pas trouvé, on sort
        End With
        Fin = wdApp.Selection.Start    'Emplacement de la fin trouvée
        Application.ThisWorkbook.Sheets("Feuil1").Range("B" & 1 + i).Value = wdApp.ActiveDocument.Range(Debut, Fin).Text
        i = i + 1
        wdApp.Selection.MoveRight , Count:=1    'Supprime la sélection  de la lettre trouvée
    Loop
    
'Nettoyage final
    If wdDocWasNotOpen Then wdDoc.Close savechanges:=wdDoNotSaveChanges
    If WordWasNotRunning Then wdApp.Quit
    Set wdApp = Nothing
End Sub
A+
 
Vote positif 0 Vote négatif
F

fred19

XLDnaute Nouveau
Re : Récuperation paragraphe Word depuis ExCEL

J'ai testé la macro c'est exactement ce qu il me fallait. J'ai juste ajouté un petit conditionnement pour faire une mise en page sur deux colonnes, mais c'est parfait. Un grand merci pour ton aide.
 
Vote positif 0 Vote négatif

Discussions similaires

J
  • Question
XL 2010 VBA Excel Insertion d'un paragraphe dans un doc Word
Réponses
0
Affichages
621
Jérémy26
J
N
  • Résolu(e)
Gérer Active.document de Word depuis Excel
Réponses
3
Affichages
2 K
n.excel
N
C
  • Question
Word Macro sur Word
Réponses
2
Affichages
2 K
CaEly
C
Philippe LAMACHE
  • Question
XL 2010 Problème avec sélection dans Word 2010 à partir du VBA Excel 2010
Réponses
5
Affichages
2 K
Philippe LAMACHE
Philippe LAMACHE
V
  • Question
XL 2010 VBA Macro : importer les 12 caractères suivant toutes les occurrences d'un mot sur une trame word dans excel
Réponses
9
Affichages
1 K
sousou
sousou
C
  • Question
Word VBA Excel-Word: Coller du texte l'un en dessous de l'autre
Réponses
1
Affichages
3 K
Conrad13
C
J
  • Question
Autres Inserer une photo dans un tableau Word depuis Excel en la redimensionnant
Réponses
2
Affichages
1 K
jeremie42
J
R
  • Question
Détecter et Insérer un paragraphe sous un autre par VBA
Réponses
0
Affichages
1 K
rem94
R
C
  • Question
Piloter word depuis Excel : MoveLeft
Réponses
4
Affichages
2 K
Cathy
C
R
  • Question
Problème Ecriture Paragraphe après paragraphe VBA Excel-Word
Réponses
4
Affichages
2 K
rem94
R

Membres actuellement en ligne

7 membres et 66 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 628
Messages
2 111 337
Membres
111 107
dernier inscrit
cdel