Macro pour copier tableau qui contient mot clé de Word vers Excel

Bonjour, je me permet de poster après beaucoup de recherche infructueuses, je souhaiterai faire une macro pour copier un tableau qui contient un mot clé de word vers excel.

Merci d'avance

Bonjour Hajar,

Difficile de t'aider si tu ne délivres pas plus d'informations.

Peux-tu joindre un exemple de ton WORD et de ton EXCEL?

Bonjour, merci pour votre réponse.

je vous envoie un exemple de mon "problème" et sachant que le tableau en question n'est pas toujours à la même disposition donc je ne peux utiliser le numéro de tableau.

Dans mon exemple je souhaiterai chercher le mot clé analyses et une fois trouvé copier tout le tableau qui le contient vers la feuille 2 du classeur.

Après peut etre que ma méthode n'est pas la bonne, le résultats est que je puisse copier certaines cellules et les coller sur la meme feuille excel et les info sont : Partie du composant vérifié ou sondé, Photos n°, Analyses n°, Etat de conservation et le numero du fichier word , et chaque prélèvements positif (lignes rouge et avec A (majuscule dans la colonne présence d'amiante) dans une ligne différente.

je voudrais avoir le même résultat présent sur la feuille 3.

Merci d'avance

78macro-tableau.docx (113.77 Ko)

Bonsoir Hajar,

Je te propose le code suivant :

Sub CopyTableObjectFromDoc()
    Const cCriteria = "Analyses"
    Const cSheetTo = "Feuil2"

    Dim oWD As New Word.Application
    Dim oDoc As Word.Document
    Dim oTableObject As Word.Table
    Dim oWordRange As Word.Range
    Dim sDocname As String
    Dim oSheet As Excel.Worksheet
    Dim oRange As Excel.Range

    'Recherche du document word à parcourir
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Add "Documents", "*.Doc*", 1
        .Show
       If .SelectedItems.Count > 0 Then
            sDocname = .SelectedItems(1)
        End If
    End With

    If Len(sDocname) > 0 Then
        'On ouvre le document WORD

        Set oDoc = oWD.Documents.Open(sDocname, , True)
        oWD.Visible = True
        oDoc.Activate
       'On boucle sur les tableaux du document
        For Each oTableObject In oDoc.Tables
            Set oWordRange = oTableObject.Range
            'On recherche le mot clé
            oWordRange.Find.Execute FindText:=cCriteria, Forward:=True
            If oWordRange.Find.Found = True Then
                'Si on trouve le mot clé, on recopie la table dans la feuille du classeur
                oTableObject.Range.WholeStory
                oTableObject.Range.Copy
                Set oSheet = ThisWorkbook.Sheets(cSheetTo)
                Set oRange = oSheet.Range("A1")
                oRange.Select
                oSheet.Paste
            End If
        Next
        'On fait le ménage
        oDoc.Close False
        oWD.Quit
        Set oWD = Nothing
        Set oDoc = Nothing
        Set oRange = Nothing
        Set oSheet = Nothing
        Set oWordRange = Nothing
    End If

End Sub

Merci beaucoup pour votre réponse rapide et pour votre temps j'essaye et je reviens vous dire ce que ça a donné.

Merci beaucoup 😘

Merci beaucoup ça marche très bien.

Bonjour, je n'arrive pas à integrer la macro en question dans ma macro actuelle, je vous explique :

J'ai une macro avec laquelle je travaille qui fait les taches suivantes :

1- Me demande de choisir le répertoire où se trouvent les words

2- une fois choisi la macro prend des données dans le premier word et les met dans les cases correspondantes dans excel

3- apres la macro ferme le premier word et passe aux autres word un par un et copie les infos en question

et voila

la macro que " GVIALLES" (merci encore une fois) m'a donné marche très bien mais avec un seul document word j'ai essayé de l'intégrer dans ma macro apres l'étape 2 mais je n'y arrive pas.

Je vous met deux word pour exemple avec le document excel que je dois remplir avec la macro en question ( qui d'ailleur beug de temps en temps je ne sais pas pourquoi)

Merci d'avance

73attestation-1.docx (238.59 Ko)
71attestation-2.docx (238.59 Ko)
71importaremplir.xlsm (49.65 Ko)

Bonsoir Hajar,

Je te propose la démarche suivante:

- Tu affectes un nom à toutes les entêtes des cellules à compléter dans le classeur EXCEL. Par exemple :

plagesnommees
  • Tu ne recopies pas le tableau WORD dans l'EXCEL (feuille 3) mais adresses directement les données WORD dans la macro de l'EXCEL (comme tu as commencé à le faire dans la procédure "Importation_Donnees_Word").
  • L'attestation WORD dont les données sont à importer est recherchée par une fonction "Filedialog" activée par un bouton présent dans la feuille "Repérages".

Dans le classeur de test joint, j'ai mis en oeuvre cette démarche dans le "module3". Tu dois compléter avec les mêmes méthodes pour la totalité des cellules à renseigner.

N'hésites pas à revenir vers moi si tu as besoin d'éclaircissements.

Bonjour, merci beaucoup GVIALLES (Gérard) vous me sauvez d'un tracas qui me prend la tête depuis des semaines.

j'adapte ça à mon cas

et encore mille merci

Petite question , pour mettre le nom du fichier selon la macro de GVIALLES j'ai mis la macro suivante :

' "Nom du fichier d rapport"

Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_du_fichier_reperage").RefersToRange.Column)

'coller le nom du fichier dans la cellule

oCell.Value = sFilename

mais ça ne marche pas : erreur de compilation variable non définie au niveau de "sfilename"

un petit coup de main?

Bonsoir Hajar,

Il te suffit de déplacer la déclaration de la variable "sFileName" au niveau supérieur dans le module :

Actuellement, elle est déclarée là :

declarationfilename1

Tu dois la déplacer là :

declarationfilename2

Bonjour, merci beaucoup pour votre aide ça m'a fait gagner beaucoup de temps.

Mille merci

Re,

est ce que c'est possible de mettre une condition avant la copie du texte dans cette partie

capture

je m'explique dans le tableau

capture2

je souhaiterai copier que les cellules correspondantes à un oui au niveau du prélèvement donc copier que les 3 dernières lignes (mais ce n'est pas toujours dans cet ordre).

Merci d'avance

Bonjour Hajar,

Je te propose le code suivante :

    ' "Denomination"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Denomination").RefersToRange.Column)
    'On récupère le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(2).Range.Text)
    'Si le texte contient "OUI", on le copie
    If InStr(1, sText, "OUI") Then
        'On affecte la valeur de la cellule avec le texte récupéré sans le dernier caractère
        oCell.Value = Left(sText, Len(sText) - 1)
    End If

Hajar,

Je me suis aperçu d'une erreur dans le dernier code envoyé. Le code correct est ici :

    ' "Denomination"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Denomination").RefersToRange.Column)
    'On récupère le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(2).Range.Text)
    'Si le texte contient "OUI", on le copie
    If InStr(1, sText, "OUI") > 0 Then
        'On affecte la valeur de la cellule avec le texte récupéré sans le dernier caractère
        oCell.Value = Left(sText, Len(sText) - 1)
    End If

ah oui maintenant ça marche.

Merci

Je vais t'embêter encore si tu le permet bien sur.

je voudrais insérer dans la colonne E le nom suivant : "nomdufichierword-photo1" après "nomdufichierword-photo2" … et ainsi de suite à chaque fois qu'une ligne de donnée s'insère comme ça.

Merci beaucoup

capture

Hajar,

Pour composer le nom de l'image, tu as besoin :

- De créer une variable de décompte de lignes dans la procédure "ajoutNouvelleAttestation" et de la faire évoluer dans la boucle "For Each" :

declarelnb evolutionnb

-D'ajouter le compteur dans l'appel à la procédure "populatePrelevement " :

appelprocedure

-De déclarer le compteur dans la procédure :

declareprocedure

-Et enfin, ajouter le code pour l'ajout du nom d'image :

    ' "Nom du fichier de l'image du prélèvement"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_image_prelevement").RefersToRange.Column)
    'On récupère le nom du fichier sans le chemin ni l'extension
    lPos1 = InStrRev(sFilename, "\")
    lPos2 = InStrRev(sFilename, ".")

    sText = Trim(Mid(sFilename, lPos1 + 1, lPos2 - lPos1 - 1)) & "-photo" & CStr(lNb)
    oCell.Value = sText

Ok parfait,

je sais que j'abuse mais est ce que c'est possible de me corriger cette partie de macro

capture

Dans la colonne I je souhaiterai mettre la condition que si le texte de la colonne K est "A" insérer dans la cellule correpondante de la colonne I "Présence d'amiante" et si on trouve "N" inserer "Absence d'amiante". J'ai mis cette macro :

capture2

Mais il n' y a que la première cellule qui est remplie je crois qu'il faut rajouter des bouts de code mais lesquels ???

Merci d'avance

Hajar,

Je ne situe pas l'endroit où tu as ajouté le code qui me paraît tout à fait correct.

Peux-tu envoyer une image du module complet?

Re, voila tout le module complet :

le bout de code qui ne marche pas est l'avant dernier ( je ne sais pas pourquoi tous mes "é" se transforment en "?")

Option Explicit
Const cSheetReperage = "Rep?rages"
Const cSheetPrelevement = "Prelevements"
Const cSheetMPCA = "MPCA"
Dim sFilename As String
Sub rechercheDiagnostic_amiante()
        'Recherche du document du Diagnostic_amiante
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Add "Doc Diagnostic_amiante", "*.doc*", 1
        .AllowMultiSelect = False
        .Show
        'Si un document a ?t? s?lectionn?
        If .SelectedItems.Count > 0 Then
            'On la variable locale au nom du fichier s?lectionn?
            sFilename = .SelectedItems(1)
        End If
    End With

    'Si la variable locale est renseign?e, on effectue le traitement du document
    If Len(sFilename) > 0 Then
        ajoutNouvelleDiagnostic_amiante sFilename
    End If

End Sub
Sub ajoutNouvelleDiagnostic_amiante(zFilename As String)

    Dim oAppWORD As Word.Application
    Dim oDoc As Word.Document
    Dim oTable1 As Word.Table, oTable2 As Word.Table
    Dim oTableRow As Word.Row
    Dim oText As Word.Shape

    Dim oSheet As Excel.Worksheet
    Dim lRowReperage As Long, lCol As Long
    Dim 1Nb As Long

    'On affecte les variables objets WORD
    Set oAppWORD = New Word.Application
    Set oDoc = oAppWORD.Documents.Open(zFilename, , True, , , , , , , , , False)
    Set oText = oDoc.Shapes(3)
    Set oTable1 = oDoc.Tables(2)
    Set oTable2 = oDoc.Tables(3)

    'On traite la feuille "Rep?rage"
    Set oSheet = ThisWorkbook.Sheets(cSheetReperage)
    'On ajoute une nouvelle ligne ? la feuille "Rep?rage"
    lRowReperage = ThisWorkbook.Names("Nature_des_travaux").RefersToRange.End(xlDown).Row + 1
    populateReperage oSheet, oText, oTable1, lRowReperage

    'Pour chaque ligne de la table2, on ajoute une ligne dans les feuilles "MPCA" et "Prelevements"
    For Each oTableRow In oTable2.Range.Rows
        If oTableRow.Index > 1 Then
           1Nb = 1Nb +1
            'On traite la feuille "MPCA"
            Set oSheet = ThisWorkbook.Sheets(cSheetMPCA)
            populateMPCA oSheet, oTable2, oTableRow.Index, lRowReperage

            'On traite la feuille "Prelevements
            Set oSheet = ThisWorkbook.Sheets(cSheetPrelevement)
            populatePrelevement oSheet, oTable2, oTableRow.Index, lRowReperage, 1Nb

        End If
    Next

    'On fait le m?nage
    oDoc.Close
    oAppWORD.Quit
    Set oText = Nothing
    Set oTable1 = Nothing
    Set oTable2 = Nothing
    Set oAppWORD = Nothing
    Set oDoc = Nothing

    MsgBox "Diagnostic amiante ajout?", vbExclamation

End Sub
Sub populateReperage(oSheet As Worksheet, oText As Word.Shape, oTable1 As Word.Table, lRow As Long)

    Dim oAppWORD As Word.Application
    Dim oDoc As Word.Document

    '************************************************************************************************************************************************
    ' Partie remplissage de la ligne de la feuille "Rep?rage"
    '************************************************************************************************************************************************
    Const cDelimDateVisite1 = "en un exemplaire original le "
    Dim oCell As Excel.Range
    Dim sText As String, lPos1 As Long, lPos2 As Long
    Dim sDate As String, dDate As Date

    'On ajoute une nouvelle ligne ? la feuille "Rep?rage"
    lRow = ThisWorkbook.Names("Nature_des_travaux").RefersToRange.End(xlDown).Row + 1

    'On renseigne la nouvelle ligne avec les donn?es r?cup?r?es dans le document word

    ' "Nature des travaux"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nature_des_travaux").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 1
    sText = oTable1.Columns(2).Cells(8).Range.Text
    'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
    oCell.Value = Left(sText, Len(sText) - 1)

    ' "R?f?rence du rapport"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Reference_Rapport").RefersToRange.Column)
    'On r?cup?re le texte Word dans le bloc de texte
    sText = oText.TextFrame.TextRange.Text
    lPos1 = InStr(1, sText, vbCr)
    'On affecte la valeur de la cellule avec la premi?re ligne du texte r?cup?r?
    oCell.Value = Mid(sText, 4, lPos1 - 4)

    ' "Date de visite"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Date_de_visite").RefersToRange.Column)
    'On recherche la position de la date de visite sur la 3?me ligne du texte
    lPos1 = InStr(lPos1 + 1, sText, vbCr)
    lPos1 = InStr(lPos1, sText, cDelimDateVisite1)
    lPos2 = InStr(lPos1, sText, vbCr)
    sDate = Trim(Mid(sText, lPos1 + Len(cDelimDateVisite1), lPos2 - (lPos1 + Len(cDelimDateVisite1))))
    'Si le texte r?cup?r? est une date, on affecte la valeur de la cellule avec la date transform?e au format date
    If IsDate(sDate) Then
        dDate = CDate(sDate)
        oCell.Value = dDate
    End If

    ' "Nom du fichier des sch?mas"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_du_fichier_schema").RefersToRange.Column)
    'coller le nom du fichier ? la cellule
    oCell.Value = sFilename & "-sch?mas"

    ' "Nom du fichier de rapport"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_du_fichier_reperage").RefersToRange.Column)
    'coller le nom du fichier ? la cellule
    oCell.Value = sFilename

    ' "Date du rapport"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Date_du_rapport").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 1

    sDate = Trim(oTable1.Columns(2).Cells(1).Range.Text)
    lPos1 = InStr(1, sDate, vbCr)
    sDate = Left(sDate, lPos1 - 1)
    'Si le texte r?cup?r? est une date, on affecte la valeur de la cellule avec la date transform?e au format date
    If IsDate(sDate) Then
        dDate = CDate(sDate)
        oCell.Value = dDate
    End If

End Sub
Sub populateMPCA(oSheet As Excel.Worksheet, oTable2 As Word.Table, zIndex As Long, lRowReperage As Long)
    '************************************************************************************************************************************************
    ' Partie remplissage d'une nouvelle ligne de la feuille "MPCA"
    '************************************************************************************************************************************************
    Dim lRow As Long
    Dim oCell As Excel.Range, oCellReperage As Range
    Dim sText As String, lPos1 As Long, lPos2 As Long

    'On ajoute une nouvelle ligne ? la feuille "MPCA"
    lRow = ThisWorkbook.Names("Reference_du_rapport").RefersToRange.End(xlDown).Row + 1

    'On indique la formule pour la cellule "R?f?rence du Rapport"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Reference_du_rapport").RefersToRange.Column)
    Set oCellReperage = ThisWorkbook.Sheets(cSheetReperage).Cells(lRowReperage, 7)
    oCell.Formula = "=" & cSheetReperage & "!" & oCellReperage.Address

    ' "Reference MPCA"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Reference_MPCA").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(2).Range.Text)
    'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
    oCell.Value = Left(sText, Len(sText) - 1)

    'Etc... pour toutes les cellules de la feuille ? renseigner

 End Sub
Sub populatePrelevement(oSheet As Excel.Worksheet, oTable2 As Word.Table, zIndex As Long, lRowReperage As Long, 1Nb As Long)
    Dim Cel As Range
    Dim num As Integer
    Dim i As Long
    '************************************************************************************************************************************************
    ' Partie remplissage d'une nouvelle ligne de la feuille "Prelevement"
    '************************************************************************************************************************************************
    Dim lRow As Long
    Dim oCell As Excel.Range, oCellReperage As Range
    Dim sText As String, lPos1 As Long, lPos2 As Long

    'On ajoute une nouvelle ligne ? la feuille "Prelevement"
    lRow = ThisWorkbook.Names("Reference_rapport_reperage").RefersToRange.End(xlDown).Row + 1

    'On indique la formule pour la cellule "R?f?rence Rapport Rep?rage"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Reference_rapport_reperage").RefersToRange.Column)
    Set oCellReperage = ThisWorkbook.Sheets(cSheetReperage).Cells(lRowReperage, 7)
    oCell.Formula = "=" & cSheetReperage & "!" & oCellReperage.Address

    ' "Denomination"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Denomination").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(2).Range.Text)
    'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
    oCell.Value = Left(sText, Len(sText) - 1)

     ' "Nom du fichier des r?sultats du laboratoire"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_du_fichier_prelevement").RefersToRange.Column)
    'coller le nom du fichier ? la cellule
    oCell.Value = sFilename & "-Pv_laboratoire"

    ' "Reference du PV d'analyse"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Reference_PV_Analyse").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(6).Range.Text)
    'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
    oCell.Value = Left(sText, Len(sText) - 1)

    ' "R?ference du prelevement"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("R?ference_prelevement").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 2
    sText = Trim(oTable2.Rows(zIndex).Cells(5).Range.Text)
    'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
    oCell.Value = Left(sText, Len(sText) - 1)

    ' "Type"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Type").RefersToRange.Column)
    'coller le nom du fichier ? la cellule
    oCell.Value = "pr?l?vement"

     'supprimer les lignes qui ne concernent pas des pr?l?vements
    Do
    Set Cel = Cells.Find(What:="NON", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
    If Cel Is Nothing Then
        Exit Do
    Else
        Rows(Cel.Row).Delete
    End If
Loop

     ' "Conclusion sur l??tat amiantif?re"
     Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Conclusion_sur_l??tat_amiantif?re").RefersToRange.Column)
    'On r?cup?re le texte Word dans le tableau 2
     sText = Trim(oTable2.Rows(zIndex).Cells(7).Range.Text)
    'Si le texte contient "A", on le copie
    If InStr(1, sText, "A") > 0 Then
        'On affecte la valeur de la cellule avec le texte r?cup?r? sans le dernier caract?re
        oCell.Value = "Pr?sence d?amiante"
    Else: oCell.Value = "Absence d?amiante"
    End If

    ' "Nom du fichier des images des pr?l?vements"
    Set oCell = oSheet.Cells(lRow, ThisWorkbook.Names("Nom_image_prelevement").RefersToRange.Column)
    'On r?cup?re le nom du fichier sans le chemin ni l'extension
    lPos1 = InStrRev(sFilename, "\")
    lPos2 = InStrRev(sFilename, ".")

    sText = Trim(Mid(sFilename, lPos1 + 1, lPos2 - lPos1 - 1)) & "-photo" & CStr(lNb)
    oCell.Value = sText

 End Sub

et par la même occasion pour le code que tu m'as envoyé pour la numérotation des fichier image ça beug comme ça :

capture3

MErci pour tout le temps que tu m'accorde

Rechercher des sujets similaires à "macro copier tableau qui contient mot cle word"