pb de cellules fusionnées dans un tableau sous word [Résolu]

[Patnel]

bonjour,

j' exploite un document word à partir d'une macro sous excel,
il faut que lorsque je rencontre un tableau je recopie ce tableau dans une feuille excel

hors les cellules du documents word sont souvent fusionnées, dont si je fais copier les cellules une par unes ça plante
si je copie le tableau en entier par copy/paste je récupére une image

si je veux spliter le tableau ça plante à la compil

voir le code

Code :

1
2
3
4
5
 
        n_l = M_objdoc.Tables(n_tab).Rows.Count
        n_c = M_objdoc.Tables(n_tab).Columns.Count
 
       M_objdoc.Tables(n_tab).Split( numrows:=n_l, numcolumns:=n_c, mergebeforesplit:=True)

ce que je veux obtenir est le tableau du document word sous une forme excel
dans un document excel que je peux exploiter

merci pour la réponse

[Heureux-oli]

Salut,

Ton problème vient du fait que lorsque tu tentes un transfert, tu adresses un objet qui n'existe pas.
La colonne ou la ligne qui contient la cellule fusionnée n'a pas le même nombre d'éléments, il faut donc les traiter séparément.

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
Sub TrfTable()
'Déclaration des objets Word
Dim oTbl As Table
'Déclaration des variables
Dim intC As Integer
Dim intR As Integer
'Déclaration des objets Excel
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
'Affection des objets
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add
Set oTbl = ActiveDocument.Tables(1)
'Boucle sur les lignes et colonnes des lignes
For intR = 1 To oTbl.Rows.Count
    For intC = 1 To oTbl.Rows(intR).Cells.Count
        'Transfert des données après nettoyage
        xlWS.Cells(intR, intC) = NetText(oTbl.Cell(intR, intC).Range.Text)
 
    Next intC
Next intR
xlApp.Visible = True
 
End Sub
'------------------------
Function NetText(stTemp As String)
   'Fonction de nettoyage     
   NetText = Left(stTemp, Len(stTemp) - 2)
End Function

Ce code devrait le faire.

[Patnel]

j'ai appliqué ton principe sur mon projet voir le code

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
'M_objdoc = objet du document word exploité
 n_lt = M_objdoc.Tables(n_tab).Rows.Count
 
 
 
 Workbooks.Add
For ligne = 1 To n_lt
 n_c = M_objdoc.Tables(n_tab).Rows(ligne).Cells.Count
 For colonne = 1 To n_c
   ActiveSheet.Cells(ligne, colonne).Value = M_objdoc.Tables(n_tab).Cell(ligne, colonne).Range.Text
 
 
   Next colonne
Next ligne

l'execution plante toujours pour la même raison: les cellules sont fusionnées

[Heureux-oli]

Salut,

Désolé, mais avec si peu d'info, je ne peux pas faire plus.

J'ai écrit mon code sur une table contenant des cellules fusionnées et je n'ai pas rencontré d'erreur, tout a été transféré dans la feuille Excel.

[Patnel]

c'est encore la faute à bill gate
les équipes qui ont developé Word se sont fachés avec ceux de excel pour une sombre histoire de prime, donc les tableaux word sont pas pareils que les tableaux excel
et c'est nous, pauvres developpeurs qui morflons.
bon en fait j'ai modifié le code pour que ça tombe en marche :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
        n_lt = M_objdoc.Tables(n_tab).Rows.Count
        n_ct = M_objdoc.Tables(n_tab).Columns.Count
 
 On Error Resume Next
 Workbooks.Add
For ligne = 1 To n_lt
 
 For colonne = 1 To n_ct
 
 mot_t = M_objdoc.Paragraphs(i_para).Range.Tables(n_tab).Cell(ligne, colonne).Range.Text
 ActiveSheet.Cells(ligne, colonne).Value = Left(mot_t, Len(mot_t) - 2)
 mot_t = "fusion"
   Next colonne
Next ligne
 
        ActiveWorkbook.SaveAs Filename:=fich
        ActiveWorkbook.Close

c'est pas trés joli avec le resume next
j'obtiens le tableau entier , les cellules fusionnées sont tagées "fusion" pour un traitement ultérieur

ça marche et ça me permet d'avancer
pour une nouvelle idée je vais demander à Johnny

merci à toi Heureux-Oli

[Patnel]

en fin de compte et aprés avoir chercher plus profondemment
j' ai trouvé le moyen de copier un tbmleau issu de word vers excel en gardant
la structure du tableau :
voici le code testé qui fonctionne
il faut utiliser l'objet application pour réussir la copie,
sinon obobtient une image et non un 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
43
44
45
46
47
48
49
50
 
Sub essai3()
 
Dim M_object As Word.Document
Dim W_file As Word.Application
 
Dim n_tab As Long
 
For Each Process In GetObject("winmgmts:").InstancesOf("Win32_process")
    If Process.Name = "WINWORD.EXE" Then Process.Terminate
Next
 
 
chem = ThisWorkbook.Path
Set ref = ThisWorkbook.Sheets(1)
n_fil = chem & "\essai.doc"
Set W_file = New Word.Application
'W_file.ShowMe
W_file.Visible = False
Set M_object = W_file.documents.Open(n_fil)
 
n_para = M_object.Paragraphs.Count
'On Error Resume Next
For i_para = 1 To n_para
 n_t = M_object.Paragraphs(i_para).Range.Tables.Count
 If n_t > 0 Then
 M_object.Paragraphs(i_para).Range.Tables(n_t).Select
 
n_l = M_object.Paragraphs(i_para).Range.Tables(1).Rows.Count
n_c = M_object.Paragraphs(i_para).Range.Tables(1).Columns.Count
 
 With W_file
    '.Selection.WholeStory
    .Selection.Copy
End With
l = 1
ThisWorkbook.Sheets("Feuil4").Activate
ThisWorkbook.Sheets("Feuil4").Paste
l = l + 10
 End If
nb_c = n_c * n_l + n_l
i_para = i_para + nb_c
Next i_para
 
 
fin:
M_object.Close
W_file.Quit
MsgBox "fini"
End Sub