Discussion :

[AK825JJ]

Bonjour à tous,

je sollicite votre aide sur un sujet qui me pose quelques difficultés et après plusieurs essais et recherches infructueuses je m’avoue vaincu.
De quoi s'agit-il :
a) je souhaite parcourir un tableau contenu dans un fichier word,
b) copier le contenu de chaque cellule,
c) et coller les éléments dans un fichier excel.

Données d'entrées : tableau Word avec deux colonnes maxi et deux ou quatre lignes maxi ( J'ai attaché au message un word avec un extrait du type de tableau concerné voir en bas )
sortie attendu : tableau d'une ligne Excel.

problèmes rencontrés :

1) Une cellule du tableau Word contient une donnée avec un style particulier n'est pas copié. Chaque tableau contient un ID du type [CDC......] dans la première cellule du tableau. Toutes les autres cellules sont bien copié mais celle-ci ne l'est pas et je ne sais pour quelle raison.
2) Pas de solution trouvée pour que les données soient copiés sur une seul ligne. Mon souhait est que toutes les données copiés soient placés dans des cellules contiguës et sur une seule ligne. j'ai essayé avec l'offset mais çà marche aléatoirement.


je vous remercie pour votre aide.


Code proposé :

Sub CopyTab()

For Itab = 1 To .Tables.Count

ReDim Tableau(1 To .Tables(Itab).Rows.Count, 1 To .Tables(Itab).Columns.Count)

For ligne = 1 To .Tables(Itab).Rows.Count

For colonne = 1 To .Tables(Itab).Columns.Count

Chaine = ""

If Exist_cell(Itab, ligne, colonne) Then

Chaine = .Tables(Itab).Cell(Row:=ligne, Column:=colonne)

Chaine = Replace(Replace(Chaine, Chr(7), ""), Chr(13), Chr(10))
Tableau(ligne, colonne) = Chaine

End If


Next colonne


Next ligne
End sub

Function Exist_cell(Num As Integer, j As Integer, k As Integer) As Boolean
Dim Chaine As String

Exist_cell = True
On Error GoTo errhdlr
Chaine = WordDoc.Tables(Num).Cell(j, k).Range.Text
Exit Function

errhdlr:
Exist_cell = False
End Functiontesttableau.docx

[EricDgn]

Bonjour,

Le problème lié à le reprise de la première cellule du tableau est qu'il ne s'agit pas d'un texte normal mais d'un texte ayant un "format de numérotation" personnalisé (onglet Accueil, groupe Paragraphe, bouton Numérotation). Pour le récupérer une possibilité est de faire un copier/coller.

Pour tout placer en une ligne, il suffit d'utiliser la fonction .Offset()

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Sub ImportTableauWord()
    Dim wdDoc As Object, wdFileName As Variant, TableNo As Integer
    Dim iRow As Long, iCol As Integer, k As Integer
 
    wdFileName = Application.GetOpenFilename("Fichiers Word (*.doc*),*.doc*", , "Document à exploiter")
    If wdFileName = False Then Exit Sub
    Set wdDoc = GetObject(wdFileName)
    With wdDoc
        TableNo = wdDoc.tables.Count
        If TableNo = 0 Then
            MsgBox "Aucun tableau dans ce document", vbExclamation, "Anomalie"
        ElseIf TableNo > 1 Then
            TableNo = InputBox("Ce document contient " & TableNo & " tableaux." & vbCrLf & _
            "Indiquer le n° du tableau à importer", "Quel tableau?", "1")
        End If
        With .tables(TableNo)
            For iRow = 1 To .Rows.Count                     '--- parcourir les lignes
                For iCol = 1 To .Columns.Count              '--- parcourir les colonnes
                    If iCol * iRow = 1 Then                 '--- si ligne 1, colonne 1: copier/coller
                        .cell(iRow, iCol).Range.Copy
                        Range("A1").PasteSpecial xlPasteValues
                        k = 1
                    Else                                    '--- sinon récupérer texte
                        On Error Resume Next                '--- erreur quand pas de cellule (lié aux cellules fusionnées)
                        Range("A1").Offset(0, k) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                        If Err.Number = 0 Then
                            k = k + 1
                        Else
                            Err.Clear
                        End If
                        On Error GoTo 0
                    End If
                Next iCol
            Next iRow
        End With
    End With
    Set wdDoc = Nothing
End Sub

Cordialement.

[AK825JJ]

Bonjour,

Le problème lié à le reprise de la première cellule du tableau est qu'il ne s'agit pas d'un texte normal mais d'un texte ayant un "format de numérotation" personnalisé (onglet Accueil, groupe Paragraphe, bouton Numérotation). Pour le récupérer une possibilité est de faire un copier/coller.

Pour tout placer en une ligne, il suffit d'utiliser la fonction .Offset()

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Sub ImportTableauWord()
    Dim wdDoc As Object, wdFileName As Variant, TableNo As Integer
    Dim iRow As Long, iCol As Integer, k As Integer
 
    wdFileName = Application.GetOpenFilename("Fichiers Word (*.doc*),*.doc*", , "Document à exploiter")
    If wdFileName = False Then Exit Sub
    Set wdDoc = GetObject(wdFileName)
    With wdDoc
        TableNo = wdDoc.tables.Count
        If TableNo = 0 Then
            MsgBox "Aucun tableau dans ce document", vbExclamation, "Anomalie"
        ElseIf TableNo > 1 Then
            TableNo = InputBox("Ce document contient " & TableNo & " tableaux." & vbCrLf & _
            "Indiquer le n° du tableau à importer", "Quel tableau?", "1")
        End If
        With .tables(TableNo)
            For iRow = 1 To .Rows.Count                     '--- parcourir les lignes
                For iCol = 1 To .Columns.Count              '--- parcourir les colonnes
                    If iCol * iRow = 1 Then                 '--- si ligne 1, colonne 1: copier/coller
                        .cell(iRow, iCol).Range.Copy
                        Range("A1").PasteSpecial xlPasteValues
                        k = 1
                    Else                                    '--- sinon récupérer texte
                        On Error Resume Next                '--- erreur quand pas de cellule (lié aux cellules fusionnées)
                        Range("A1").Offset(0, k) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                        If Err.Number = 0 Then
                            k = k + 1
                        Else
                            Err.Clear
                        End If
                        On Error GoTo 0
                    End If
                Next iCol
            Next iRow
        End With
    End With
    Set wdDoc = Nothing
End Sub

Cordialement.

Bonjour, je vous remercie infiniment pour votre réponse et le temps passé sur mon sujet. Un grand merci a vous! Ça fait des semaines que je tourne en rond et la vous m'offrais une porte de sortie .