XL 2019 VBA Import d'un tableau Word sur Excel

Jérémy26 · 31 Janvier 2022

Bonjour, j'ai fais un programme VBA sur Excel qui ouvre un document Word copie un tableau et le colle sur un feuille de mon Excel.
Le problème c'est que lorsque j'ai des retour à la ligne dans une case du tableau, Excel me crée une autre cellule. Donc par exemple : Si dans un case (cellule) de mon tableau Word j'ai du texte avec 2 retour à la ligne dans mon texte, une fois importé mon tableau dans Excel on a 3 cellules avec le texte séparé en trois du coup, au lieu d'une cellule sur Word.
Merci de bien vouloir m'aider.

p56 · 31 Janvier 2022

Bonjour,
Il suffit de remplacer à la volée le retour chariot par un Chr(10) par exemple du genre :

VB:

Dim S As String

    S = WordDoc.Tables(1).Cell(1, 1).Range.Text
    S = Replace(S, vbCrLf, Chr(10))
    ThisWorkbook.Sheets("Feuil1").Range("A1").Value = S

Jérémy26 · 1 Février 2022

p56 à dit:
Bonjour,
Il suffit de remplacer à la volée le retour chariot par un Chr(10) par exemple du genre :

VB:

Dim S As String S = WordDoc.Tables(1).Cell(1, 1).Range.Text S = Replace(S, vbCrLf, Chr(10)) ThisWorkbook.Sheets("Feuil1").Range("A1").Value = S

Merci beaucoup pour ta réponse

Jérémy26 · 2 Février 2022

Avec cette solution je ne pouvais plus faire directement un copier d'un tableau Word puis coller sur Excel en macro. J'ai utilisé cette solution pour récupérer les données de mon tableau case par case. Cependant lorsque j'ai des case fusionnées sur mon tableau Word, je récupère bien la donné de la case la plus à gauche mais je traite aussi les autre ce qui mets en erreur ma macro. J'aimerai savoir comment je peux faire pour déterminer si mes case son fusionné ou pas sur le document Word pour adapter mon programme et récupérer juste la case de gauche, merci de m'apporter une solution à ce nouveau problème.

job75 · 2 Février 2022

Bonjour Jérémy26, p56,

En général copier Word vers Excel ne pose pas de problème :

VB:

Sub CopierWord()
'le document Word doit être ouvert
Application.ScreenUpdating = False
With Feuil1 'CodeName à adapter
    .Cells.Delete 'RAZ
    GetObject(, "Word.Application").ActiveDocument.Tables(1).Range.Copy 'copie Word
    .[A1].Select
    .Paste 'colle sur Excel
    .[A1].Select
End With
End Sub

Ouvrez le document Word et cliquez sur le bouton du fichier Excel.

A+

Jérémy26 · 2 Février 2022

job75 à dit:
Bonjour Jérémy26, p56,

En général copier Word vers Excel ne pose pas de problème :

VB:

Sub CopierWord() 'le document Word doit être ouvert Application.ScreenUpdating = False With Feuil1 'CodeName à adapter .Cells.Delete 'RAZ GetObject(, "Word.Application").ActiveDocument.Tables(1).Range.Copy 'copie Word .[A1].Select .Paste 'colle sur Excel .[A1].Select End With End Sub

Ouvrez le document Word et cliquez sur le bouton du fichier Excel.

A+

Mon problème c'est les retour à la ligne qui crée de nouvelles cellules lors que j'utilise cette solution.
J'ai modifier le document word avec tableau type pour que vous puissiez visualiser mon problème concrètement. Cordialement

Jérémy26 · 2 Février 2022

p56 à dit:
Jérémy, avez-vous vu ma réponse-démo juste avant votre dernier message?

Oui j'ai vu votre démo, je suis débutant en VBA, j'essai de comprendre comment ça fonction pour pouvoir l'appliquer sur un tableau type comme celui-ci.
Pour e moment j'obtiens ce résultat :
Merci pour ta démo.

p56 · 2 Février 2022

Oui c'est curieux?! je constate le même effet ... mais je vais continuer à chercher ce qui coince pour ce doc ...
Edit : je suis un idiot, j'ai interverti les lignes et les colonnes!
Voici ici un code bien plus propre :

Code:

Sub Demo_Recup_Tableaux()
Dim lg As Integer, cl As Integer, i As Integer, j As Integer, k As Integer
Dim S As String, T As Variant

    Open_Word Word_A_Lire
    With WordDoc
        For i = 1 To .Tables.Count
            lg = .Tables(i).Rows.Count
            cl = .Tables(i).Columns.Count
            ReDim T(1 To lg, 1 To cl)
            For j = 1 To lg
                For k = 1 To cl
                    S = ""
                    If Exist_cell(i, j, k) Then
                        S = .Tables(i).Cell(j, k).Range.Text
                        S = Replace(Replace(S, Chr(7), ""), Chr(13), Chr(10))
                        T(j, k) = S
                    End If
                Next k
            Next j
            With ThisWorkbook.Sheets("Feuil1")
                .Cells(2 + ((i - 1) * 15), 1).Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
        Next i
    End With
    Close_Word True
End Sub

Jérémy26 · 2 Février 2022

p56 à dit:

Oui c'est curieux?! je constate le même effet ... mais je vais continuer à chercher ce qui coince pour ce doc ...
Edit : je suis un idiot, j'ai interverti les lignes et les colonnes!
Voici ici un code bien plus propre :

Code:

Sub Demo_Recup_Tableaux()
Dim i As Integer, j As Integer, k As Integer, lg As Integer, cl As Integer
Dim S As String, T As Variant, ce As Object

    Open_Word Word_A_Lire
    With WordDoc
        For i = 1 To .Tables.Count
            lg = .Tables(i).Rows.Count
            cl = .Tables(i).Columns.Count
            ReDim T(1 To lg, 1 To cl)
            For j = 1 To lg
                For k = 1 To cl
                    S = ""
                    If Not Exist_cell(i, j, k) Then
                        S = WordDoc.Tables(i).Cell(j, k).Range.Text
                        S = Replace(Replace(S, Chr(7), ""), Chr(13), Chr(10))
                        T(j, k) = S
                    End If
                Next k
            Next j
            ThisWorkbook.Sheets("Feuil1").Cells(2, i * 10).Resize(UBound(T, 1), UBound(T, 2)) = T
        Next i
    End With
    Close_Word
End Sub

Merci beaucoup pour ton aide

Jérémy26 · 21 Février 2022

Bonjour je viens de remarquer que j'ai des données avec des retours à la ligne avec de puce "•" est possible de garde les puces ? c'est surement ce bout de programme qui me les enlèves.

VB:

S = .Tables(i).Cell(j, k).Range.Text
S = Replace(Replace(S, Chr(7), ""), Chr(13), Chr(10))
T(j, k) = S

Jérémy26 · 11 Avril 2022

p56 à dit:

Oui c'est curieux?! je constate le même effet ... mais je vais continuer à chercher ce qui coince pour ce doc ...
Edit : je suis un idiot, j'ai interverti les lignes et les colonnes!
Voici ici un code bien plus propre :

Code:

Sub Demo_Recup_Tableaux()
Dim lg As Integer, cl As Integer, i As Integer, j As Integer, k As Integer
Dim S As String, T As Variant

    Open_Word Word_A_Lire
    With WordDoc
        For i = 1 To .Tables.Count
            lg = .Tables(i).Rows.Count
            cl = .Tables(i).Columns.Count
            ReDim T(1 To lg, 1 To cl)
            For j = 1 To lg
                For k = 1 To cl
                    S = ""
                    If Exist_cell(i, j, k) Then
                        S = .Tables(i).Cell(j, k).Range.Text
                        S = Replace(Replace(S, Chr(7), ""), Chr(13), Chr(10))
                        T(j, k) = S
                    End If
                Next k
            Next j
            With ThisWorkbook.Sheets("Feuil1")
                .Cells(2 + ((i - 1) * 15), 1).Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
        Next i
    End With
    Close_Word True
End Sub

Bonjour, j'ai un soucis par rapport à ce programme.
Je récupère bien le texte d'une case dans la tableau word depuis l'excel mais si mon texte avait une tabulation avec puce, je la perd. Pouvez-vous m'aider ?
@p56

job75 · 11 Avril 2022

Bonjour Jérémy26,

Copy-Paste traite correctement les puces Word il me semble, bien sûr avec renvois à la ligne.

A+

Jérémy26 · 12 Avril 2022

Le problème de cette méthode c'est que au résultat final une fois collé j'ai des cellules fusionné et des que j'ai un retour à la ligne avec puce le test va sur une autre cellule.

XL 2019 VBA Import d'un tableau Word sur Excel

Jérémy26

XLDnaute Nouveau

p56

XLDnaute Occasionnel

Jérémy26

XLDnaute Nouveau

Jérémy26

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Jérémy26

XLDnaute Nouveau

Pièces jointes

Jérémy26

XLDnaute Nouveau

Pièces jointes

p56

XLDnaute Occasionnel

Pièces jointes

Jérémy26

XLDnaute Nouveau

Jérémy26

XLDnaute Nouveau

Jérémy26

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Jérémy26

XLDnaute Nouveau

Discussions similaires