Contrôle de contenu et Style de word vers Excel
Bonjour,
Je me permets de faire appel à vos connaissance pour résoudre un problème sur quel je planche depuis quelques jours.
J'ai retourné la plupart des forums d'aide mais je ne parviens pas à trouver le code ou les bouts de code me permettant d'avancer.
J'ai un fichier word, ouvert, constitué de titres et de paragraphes de différents styles et d'un certain nombre de Contrôle de contenu de texte enrichi.
Cela ressemble à :
TITRE 1 (Style Titre 1)
SOUS-TITRE 1 (Style Titre 2)
Texte (Style Normal)
Contrôle de contenu de texte enrichi 1
TITRE 2 (Style Titre 1)
Contrôle de contenu de texte enrichi 2
Texte (Style Normal)
Contrôle de contenu de texte enrichi 3
Je souhaiterais pouvoir récupérer les Titres, sous-titres et les Contrôle de contenu de texte enrichi et les coller dans un fichier excel (ouvert), dans la forme suivante:
COLONNE A | COLONNE B | COLONNE C
TITRE 1 | SOUS-TITRE 1 | Contrôle de contenu de texte enrichi 1
TITRE 2 | | Contrôle de contenu de texte enrichi 2
TITRE 2 | | Contrôle de contenu de texte enrichi 3
D'après mes recherches il semble pouvoir automatiser tout cela avec une macro en utilisant les styles et les objets Contrôle de contenu de texte enrichi, mais je parviens par à faire quoi que ce soit.
Merci par avance pour votre aide.
Bonjour,
Pour commencer voici une démo : le code demande à pointer sur un doc, boucle sur les paragraphes et pour chacun affiche le style et son contenu.
Sub Recup_Styles_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer
ChDrive Left(ActiveWorkbook.Path, 1)
ChDir ActiveWorkbook.Path
NDF = Application.GetOpenFilename
If Not NDF = False Then
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)
lg = 2
For Each Prgf In WordDoc.Paragraphs
With Prgf.Range
If Len(.Text) > 2 Then
ActiveSheet.Range("A" & lg).Value = .Style
ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
lg = lg + 1
End If
End With
Next Prgf
WordDoc.Close
WordApp.Application.Quit
Set Prgf = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
End If
End Sub
Pierre
Bonjour Pierre,
Merci pour ton message et pour ton début de solution.
J'ai commencé à bidouiller ton code afin que ne remontent que les styles qui m’intéressent (dans l'exemple Titre 1, Titre 2 et Titre 3 ).
C'est lent mais ça fonctionne.
Sub Recup_Style_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer
ChDrive Left(ActiveWorkbook.Path, 1)
ChDir ActiveWorkbook.Path
NDF = Application.GetOpenFilename
If Not NDF = False Then
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.documents.Open(NDF, ReadOnly:=True)
lg = 2
For Each Prgf In WordDoc.Paragraphs
With Prgf.Range
If Prgf.Style = "Titre 1" Or Prgf.Style = "Titre 2" Or Prgf.Style = "Titre 3" Then
ActiveSheet.Range("A" & lg).Value = .Style
ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
lg = lg + 1
End If
End With
Next Prgf
WordDoc.Close
WordApp.Application.Quit
Set Prgf = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
End If
End Sub
Me reste à trouver comment extraire les Contrôles de contenu, puis à trouver la manière de les ranger comme je souhaite dans Excel
(Colonne A - Titre 1, Colonne B - Titre 2,...)
Merci encore Pierre.
Tu peux essayer un truc du genre :
Sub Recup_Styles_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object, Ctrl As Object
Dim lg As Integer
ChDrive Left(ActiveWorkbook.Path, 1)
ChDir ActiveWorkbook.Path
NDF = Application.GetOpenFilename
If Not NDF = False Then
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)
lg = 2
For Each Prgf In WordDoc.Paragraphs
With Prgf.Range
If .Style = "Titre 1" Or .Style = "Titre 2" Or .Style = "Titre 3" Then 'If Len(.Text) > 2 Then
ActiveSheet.Range("A" & lg).Value = .Style
ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
For Each Ctrl In .ContentControls
ActiveSheet.Range("C" & lg).Value = Ctrl.Range.Text
Next Ctrl
lg = lg + 1
End If
End With
Next Prgf
WordDoc.Close
WordApp.Application.Quit
Set Ctrl = Nothing
Set Prgf = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
End If
End Sub
Pierre,
Les ContentControls ne sont pas reconnus avec ta proposition. J'ai essayé de déclarer Ctrl comme ContentControl mais j'ai l'erreur Type non défini.
Une idée?
Cordialement,
Bonjour,
Finalement avec le code suivant ça se passe relativement bien. J'ai assigné un style au texte de mes ContentControls (titre 4)
Sub ()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer, i As Integer, C As Integer, Cdest As Integer
Dim ligne As Long
ChDrive Left(ActiveWorkbook.Path, 1)
ChDir ActiveWorkbook.Path
NDF = Application.GetOpenFilename
If Not NDF = False Then
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.documents.Open(NDF, ReadOnly:=True)
lg = 2
For Each Prgf In WordDoc.Paragraphs
With Prgf.Range
If Prgf.Style = "Titre 1" Or Prgf.Style = "Titre 2" Or Prgf.Style = "Titre 3" Then
Sheets("Feuil1").Range("A" & lg).Value = .Style
Sheets("Feuil1").Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
lg = lg + 1
Else
If Prgf.Style = "Titre 4;" Then
For Each Ctrl In .ContentControls
Sheets("Feuil1").Range("A" & lg).Value = .Style
Sheets("Feuil1").Range("B" & lg).Value = Ctrl.Range.Text
lg = lg + 1
Next Ctrl
End If
End If
End With
Next Prgf
WordDoc.Close
WordApp.Application.Quit
Set Ctrl = Nothing
Set Prgf = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
End If
J'ai toutefois une autre questions. Mes ContentControls sont parfois composés de retour chariot ou de listes. Est-il possible de conserver cette mise en forme lors de la copie vers Excel? En effet avec la méthode actuelle tout est collé à la suite.
Merci