Inserer un tableau provenant d'un doc word sur excel avec vba

Version imprimable

1 pièce(s) jointe(s)

Bonjour !

je souhaite recuperer un tableau d'un fichier work pour l'analyser sous excel. Aprés plusieurs recherches jai trouvée un programme ( que je vous met ci-dessous) qui aurait dû fonctionner mais non .. j'obtiens un chargement puis un message d'erreur " Microsoft excel attend la fin de l'execution d'une action OLE d'une autre application" je ne comprend pas le message d'erreur et ne vois pas du tout ou est mon erreur si vous avez une idées :roll:

je vous met aussi un petit bout de mon tableau sous word .

Code:

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
Sub fichiercdc()
 
'nécéssite d'activer la référence Microsoft Word xx.x Object Library
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Fichier As Variant
 
'affichage boite de dialogue pour choisir un document Word
Fichier = Application.GetOpenFilename("Text Files (*.doc*), *.doc*")
If Fichier = False Then Exit Sub
 
'le document Word est supposé fermé avant le lancement de la macro
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False 'pour que word reste masqué pendant l'opération
Set WordDoc = WordApp.Documents.Open(Fichier) 'ouverture du fichier Word
 
If WordDoc.Tables.Count < 2 Then 'verifie si le document possede bien le tableau
WordDoc.Close False
WordApp.Quit
MsgBox "Le document sélectionné : " & Chr(10) & Chr(10) & _
Fichier & Chr(10) & Chr(10) & "ne posséde pas le tableau spécifié", , "Message"
Exit Sub
End If
 
WordDoc.Tables(1).Range.Copy 'copie du tableau Word
'dans Word chaque tableau est indexé
'ici l'index est à 2 car le premier index correspond au cadre autour du titre du
'document Word
 
Range("A1").Select
ActiveSheet.Paste 'collage des données dans Excel
 
WordDoc.Close False 'ferme le document Word sans sauvegarde
WordApp.Quit 'ferme l'application Word
End Sub

Bonjour,
Pas le temps de regarder ton code mais voici une procédure test qui fonctionne
Le fichier word doit être dans un sous-répertoire (ici Data) du répertoire où se trouve le classeur Excel.
Copie du premier tableau d'un document nommé TABLEAU.doc dans une nouvelle feuille du classeur
Pour modifier le nom du sous répertoire et/ou du document Word, voir la valeur de la constante FileName
Il y a lieu de référencer Microsoft word xx.x 0bject Library
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub ImportWordTable() ' Nécessite d'activer la reference Microsoft word xx.x 0bject Library ' Déclaration des variables & constante Const FileName As String = "data\TABLEAU.doc" ' Sous-dossier + nom du fichier word Dim oDoc As Word.Document Dim oWrd As Word.Application Dim Folder As String, FullName ' Folder = ThisWorkbook.Path ' FullName = Folder & "\" & FileName Set oWrd = New Word.Application With oWrd: .ShowMe: .Visible = True: End With ' Ouvre le document Word (Fichier.doc) Set oDoc = oWrd.Documents.Open(FullName, ReadOnly:=True) oDoc.Tables(1).Range.Copy ' Copie du premier tableau ThisWorkbook.Worksheets.Add ' Insère une feuille ActiveSheet.Paste ' Colle les données dans Excel oWrd.Application.Quit ' Fermeture de Word Set oWrd = Nothing: Set oDoc = Nothing End Sub

Bonjour,

Ce qui donnerait quelquechose comme ça (attention, il faut impérativement libérer les appels à word, avec ou sans tableau)

Code:

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
Sub ImportWordTable()
 ' Nécessite d'activer la reference Microsoft word xx.x 0bject Library
 ' Déclaration des variables & constante
 Dim FileName As Variant
 Dim oDoc As Word.Document
 Dim oWrd As Word.Application
 Dim Folder As String, FullName
 '
 
    FileName = Application.GetOpenFilename("Word documents (*.doc*), *.doc*")
    If FileName = False Then Exit Sub
 
    Set oWrd = New Word.Application
    With oWrd: .ShowMe: .Visible = True: End With
 
' Ouvre le document Word (Fichier.doc)
    Set oDoc = oWrd.Documents.Open(FileName, ReadOnly:=True)
 
    With oDoc
 
        If .Tables.Count > 1 Then 'verifie si le document possede bien le tableau
 
            .Tables(1).Range.Copy
            Debug.Print ThisWorkbook.Sheets(1).Range("A1").Address
            ThisWorkbook.Sheets(1).Paste
 
        Else:
            MsgBox "Le document sélectionné : " & vbCrLf & FileName & vbCrLf & _
                "ne posséde pas le tableau spécifié", vbExclamation, "Erreur"
 
        End If
 
    End With
 
' Dans tous les cas, on ferme proprement
 
    oDoc.Close False
    oWrd.Application.Quit
    Set oWrd = Nothing: Set oDoc = Nothing
 
 
End Sub