Problème macro Word vers Excel Paragraphe.Range.Sentences(1).Text

Bonjour à tous,

Tout d'abord tous mes meilleurs vœux pour cette nouvelle année.

J'ai réalisé une macro qui permet de passer des titres de Word vers Excel.

Ca fonctionne à 95% et j'aurai besoin de votre aide pour les 5% restants. Je pense qu'il s'agit d'un problème sur ma fonction Paragraphe.Range.Sentences(1).Text

Le bug concerne le fichier excel qui prend au début un sous-titre 2 fois est le place au début de mon programme. Je n'arrive pas à comprendre pourquoi.

Merci d'avance pour votre aide.

Bien à vous,

Jérémie

Bonjour,

Si je peux me permettre le code est un peu ... fouillis.

Le doc contenant une table des matières on peut faire bien plus simple.

Voici une proposition qui consiste à lire la table des matières du doc sur lequel on va pointer et qui la place dans un tableau T.

Ensuite on peut faire ce qu'on veut des valeurs de T : ici un simple collage dans la feuille en cours.

Pierre

Code à placer dans un module quelconque d'un fichier xl =>

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Toc_Word()
Dim NDF As Variant, T() As String
Dim WordApp As Object, WordDoc As Object

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        On Error GoTo errhdlr
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)

        T = Split(WordDoc.TablesOfContents(1).Range, Chr(13))

        WordDoc.Close
        WordApp.Application.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing

        ActiveSheet.Range("A1").Resize(UBound(T, 1)) = Application.Transpose(T)
    End If
    Exit Sub

errhdlr:
    If Not WordApp Is Nothing Then WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    MsgBox "Pas de sommaire à importer", , Err.Description
End Sub

Merci beaucoup Pierre pour ton retour.

Oui tu as raison, je bidouille plus que je programme car je ne suis pas du métier mais je suis toujours à l'écoute de conseils afin de m'améliorer.

J'ai besoin de séparer mes lignes, mes colonnes et faire des sommes en fonction de mes chapitres, etc...

Le but étant que tout se fasse de façon automatique comme je l'ai fait dans mon programme, avec la même mise en page.

Or, avec ton programme je ne vois pas comment y arriver, tout est récupéré en une seul fois.

Pourrais tu m'apporter ton aide stp.

Merci,

Alors, "en une seule fois" oui et non.
Dans ma proposition la table des matières est placée ligne par ligne dans la variable T. Il est facile ensuite de manipuler chaque item séparément avec une simple boucle For i = 1 To UBound(T)

Exemple ici avec une légère modif du code proposé, chaque item lu est collé une ligne sur 2 en colonne B :

ActiveSheet.Cells(i * 2, "B").Value = T(i, 1)

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Toc_Word()
Dim T As Variant, Ndf As Variant, i As Integer

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    Ndf = Application.GetOpenFilename
    If Not Ndf = False Then
        T = Toc(Ndf)
        For i = 1 To UBound(T)
            ActiveSheet.Cells(i * 2, "B").Value = T(i, 1)
        Next i
    End If
End Sub

Function Toc(Ndf As Variant) As Variant
Dim T() As String, WordApp As Object, WordDoc As Object

    On Error GoTo errhdlr
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(Ndf, ReadOnly:=True)

    T = Split(WordDoc.TablesOfContents(1).Range, Chr(13))
    Toc = Application.Transpose(T)

    WordDoc.Close
    WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    Exit Function

errhdlr:
    If Not WordApp Is Nothing Then WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    MsgBox "Pas de sommaire à importer", , Err.Description
End Function

(suite)

Et comme les titres contiennent des tabulations (vbtab) on peut aussi séparer chaque ligne en n° et titre, par exemple, en colonne B et C

Sub Toc_Word()
Dim T As Variant, Ndf As Variant, i As Integer, S As Variant

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    Ndf = Application.GetOpenFilename
    If Not Ndf = False Then
        With ActiveSheet
            T = Toc(Ndf)
            For i = 1 To UBound(T)
                S = Split(T(i, 1), vbTab)
                On Error Resume Next
                .Cells(i * 2, "B").Value = "'" & S(0)
                .Cells(i * 2, "C").Value = S(1)
            Next i
        End With
    End If
End Sub