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
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
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 :
- 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?
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
je m'explique dans le tableau
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
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" :
-D'ajouter le compteur dans l'appel à la procédure "populatePrelevement " :
-De déclarer le compteur dans la procédure :
-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
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 :
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 :
MErci pour tout le temps que tu m'accorde