XL 2010 Problème avec sélection dans Word 2010 à partir du VBA Excel 2010

Philippe LAMACHE

XLDnaute Junior
Bonjour à tous,
Je me lance dans la récupération de tableaux Word vers Excel.
(Capture du fichier Word)
Capture.JPG

Après quelque recherches sur le Net, Voici ce que j'ai réussi à "Bricoler":

VB:
Sub copieTableauWordVersExcel()
Dim WordApp As WORD.Application
Dim WordDoc As WORD.Document
Dim sStr As String, sStr1 As String, sNom As String
Dim oTbl As Table
sNom = ThisWorkbook.Path & "\" & "2016- 24556.doc"
    Set WordApp = New WORD.Application
    Set WordDoc = WordApp.Documents.Open(Filename:=sNom, ReadOnly:=True)
WordApp.Visible = True
WordApp.ActiveWindow.View.Zoom.Percentage = 100

WordApp.Selection.HomeKey wdStory
WordApp.Selection.MoveStart Unit:=5, Count:=100
    sStr = "ANNEXE 1 :"
With WordApp.Selection.Find
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Execute FindText:=sStr
    End With
' Là, je sélectionne le titre complet de mon paragraphe
    WordApp.Selection.Expand wdParagraph
' Et, jusque là, ça va, c'est après que cela se gâte pour moi
AA = WordApp.Selection.Range.Text
BB = WordApp.Selection.Information(wdFirstCharacterLineNumber)
' Ce qu'il me faudrait c'est le n° de ligne depuis le début du document Word (comme ci-dessous)
' ou, l'idéal, sélectionner tout entre mes 2 titres (ANNEXE 1 et ANNEXE 2)

'BB = WordApp.Selection.Range(Start:=0, End:=Selection.Start).ComputeStatistics(wdStatisticLines)
' Il y a une erreur que je n'arrive pas à corriger

    WordApp.Selection.MoveRight Unit:=wdTables, Count:=1, Extend:=wdExtend
WordApp.Selection.HomeKey wdStory
WordApp.Selection.MoveStart Unit:=5, Count:=100
    sStr1 = "ANNEXE 2 :"
With WordApp.Selection.Find
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Execute FindText:=sStr1
    End With
    WordApp.Selection.Expand wdParagraph
CC = WordApp.Selection.Range.Text
DD = WordApp.Selection.Information(wdFirstCharacterLineNumber)
'DD1 = WordApp.Selection.Range(Start:=0, End:=Selection.Start).ComputeStatistics(wdStatisticLines)

'Là j'espérais sélectionner tout entre mes 2 titres (ANNEXE 1 et ANNEXE 2) mais pas moyen
'MaSel = WordApp.Selection(AA, CC)

For Each oTbl In WordApp.Selection.Tables
    oTbl.Select
    ' Puis, quand ma "selection" fonctionnera ... Je pourrais copier mes tableaux vers Excel
Next oTbl
 
    Set WordApp = Nothing
End Sub

Mais comme je l'explique dans mon code par des commentaires, j'ai un souci de sélection.
Quelqu'un peut-il me venir en aide ?
Par avance, merci.
 

Philippe LAMACHE

XLDnaute Junior
Bonjour Staple1600,
Comme demandé, voici mes fichiers.
En fait j'ai besoin de copier les tableaux des pages 50 à 59 du Word vers l'onglet "WORD" d'Excel (au fil de l'eau idem à l'onglet "WORD (2)").
Pour info :
Module => Extract_Tab_Word
Procédure => Sub CopieTableauWordVersExcel()
 

Pièces jointes

  • EIP ED.zip
    289.3 KB · Affichages: 1

Philippe LAMACHE

XLDnaute Junior
Bonjour Staple1600,

J'ai trouvé la solution (pas "très propre", comme à mon habitude, mais je vais m'en contenter !) en relisant ma réponse de tout à l'heure (envoi fichiers).
En fait, je sélectionne mes pages (en récupérant leur n°) puis je traite les tableaux de ma sélection.

Voici donc mon code modifié:

VB:
Sub CopieTableauWordVersExcel()
Dim WordApp As WORD.Application
Dim WordDoc As WORD.Document
Dim sStr As String, sStr1 As String, sNom As String
Dim oTbl As Table
sNom = ThisWorkbook.Path & "\" & "2016- 24556.doc"
    Set WordApp = New WORD.Application
    Set WordDoc = WordApp.Documents.Open(Filename:=sNom, ReadOnly:=True)
WordApp.Visible = True
WordApp.ActiveWindow.View.Zoom.Percentage = 100
WordApp.Selection.HomeKey wdStory
WordApp.Selection.MoveStart Unit:=5, Count:=200
    sStr = Feuil1.[AG1].Value ' "ANNEXE 1 :"
With WordApp.Selection.Find
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Execute FindText:=sStr
    End With
PgDebut = WordApp.Selection.Information(wdActiveEndPageNumber)
WordApp.Selection.HomeKey wdStory
WordApp.Selection.MoveStart Unit:=5, Count:=200
    sStr1 = Feuil1.[AH1].Value ' ": EIP FONCTION"
With WordApp.Selection.Find
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Execute FindText:=sStr1
    End With
PgFin = WordApp.Selection.Information(wdActiveEndPageNumber)
    With WordApp
             .Visible = True
             rDeb = .Selection.Goto(What:=wdGoToPage, Which:=wdGoToNext, Name:=PgDebut).Start
             rFin = .Selection.Goto(What:=wdGoToPage, Which:=wdGoToNext, Name:=PgFin).Start
    End With
    WordApp.ActiveDocument.Range(rDeb, rFin).Select
For Each oTbl In WordApp.Selection.Tables
    oTbl.Range.Copy
    ThisWorkbook.Activate
    Feuil6.Select
    [A1048576].End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
Next oTbl
    Set WordApp = Nothing
End Sub

Merci de m'avoir guidé vers la solution en ayant pris le temps de me lire et de me rappeler qu'il est préférable de mettre des fichiers pour accompagner la question.

Bon WE.
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil,

Petite question
Si on fait une recherche sur : EIP FONCTION dans Word on trouve six occurences
(Laquelle est la bonne)

Au final, combien de tableaux tu veux copier dans Excel?

PS: Tu es sur que ton document Word n'est pas réservé strictement à l'usage interne de ton entreprise?
Il est peut être diffusé sur un forum public?
 

Discussions similaires

Haut Bas