Créer une macro de fichiers word vers Excel
Bonjour à tous
Continuant mon travail de mise à jour des fichiers utilisés par une équipe sur le terrain, je viens vers vous avec une nouvelle question
L'équipe suit des personnes, chaque personne a un dossier word, et j'aimerai rapatrier une partie de l'ensemble des informations dans un tableau excel.
Je m'explique: il y a un suivi de l'IMC (indice de masse corporelle) de ces personnes, avec des chiffres, dans un tableau dans le fichier word, avec la date, le poids et la taille.
Le fichier source est de type :
Initiale du quartier (3 lettres) - Nom Prénom- N° de dossier
Il y a environ 340 personnes suivis, donc 340 numéros de fichiers sources différents
Je poste le modèle source du document
(le fichier normal est différent, mais je ne poste que la partie utile, le tableau est toujours en page 3)
J'aimerai rentrer toutes ces infos dans un tableau avec pour chaque numéro de dossier le poids, la taille et l'IMC ainsi que la date associée
L'idée est à terme de retravailler ces documents pour créer des macros qui rentreraient automatiquement ces données sur un tableur, mais pour l'instant ce n'est pas fait
Aussi: est ce faisable rétrospectivement?
Merci pour vos réponses!
Salut,
Voici comment insérer les valeurs de ton tableau dans Excel.
Il faut activer la bibliothèque Microsoft Word xx.x Object Library
Sub ImportWord()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("word.application")
WordApp.Visible = False 'Word reste masqué pendant l'opération
Set WordDoc = WordApp.Documents.Open("C:\...\Dossier de suivi_modèle_forum.docx") 'ouvre le document Word
For i = 1 To WordDoc.Tables(1).Rows.Count 'Tables(1) si le tableau à copier est le 1er du document
For j = 1 To WordDoc.Tables(1).Columns.Count
Cells(i, j).Value = Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(j).Cells(i).Range.Text)
If Cells(i, j).Value = "" Then Exit Sub
Next j
Next i
WordDoc.Close 'fermeture document Word
WordApp.Quit 'fermeture session Word
End Sub
Merci pour ta réponse
Alors étant un grand débutant en VBA j'ai essayé de créer une macro avec ce que tu m'as dit
Le problème étant que dès la 2ème ligne (Dim WordApp As Word.applicaiton), il me met:
Erreur de compilation: type défini par l'utilisateur non défini
Sinon de manière générale, est ce possible de le régler à selectionner tous les fichiers présents dans un dossier?
Comme il ya plus de 340 fichiers, avec des noms à chaque fois différents, j'aimerai éviter de devoir rentrer à chaque fois le nom du fichier.
Salut,
boltu a écrit :Le problème étant que dès la 2ème ligne (Dim WordApp As Word.applicaiton), il me met:
Erreur de compilation: type défini par l'utilisateur non défini
Il faut que dans l'éditeur vba, dans Outils --> Références, tu actives la bibliothèque "Microsoft Word xx.x Object Library"
Concernant le parcours des fichiers word, tu peux essayer cela.
Sub ImportWord()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, Fichier As String
Dim i As Integer, j As Integer, p As Integer
p = 0
Chemin = "C:\TonChemin\" 'chemin où se trouve des fichiers
'----------------------------------------------------
'Boucle sur tous les fichiers doc du répertoire
'----------------------------------------------------
Fichier = Dir(Chemin & "*.doc") 'ou docx
Set WordApp = CreateObject("word.application")
Do While Len(Fichier) > 0
WordApp.Visible = True 'Word reste affiché pendant l'opération / Tu peux en mettant False masqué word pour + de rapidité
Set WordDoc = WordApp.Documents.Open(Chemin & "\" & Fichier) 'ouvre le document Word
For i = 1 To WordDoc.Tables(1).Rows.Count 'Tables(1) si le tableau à copier est le 1er du document
p = p + 1
For j = 1 To WordDoc.Tables(1).Columns.Count
Cells(p, j).Value = Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(j).Cells(i).Range.Text)
If j = 1 And Cells(p, j).Value = "" Then GoTo Suite
Next j
Next i
Suite:
WordDoc.Close 'fermeture document Word
Fichier = Dir() 'récupére le nom du prochain fichier
Loop
WordApp.Quit 'fermeture session Word
End Sub
Merci pour ta réponse
Alors du coups:
Pour ton premier fichier:
Sur le tableur excel, il me copie la première ligne du tableau...bon c'est mieux que rien mais j'aimerai bien avoir la suite des lignes du tableau^^
Autrement serait ce possible de mettre le numéro de dossier (page 1) quelque part au dessus des lignes insérées
Pour le deuxième fichier:
Il réfléchit...mais il ne se passe rien
J'ai bien modifié le format pour un .docx mais nada
Merci d'avance!
tu peux poster pour exemple les deux fichiers Word que tu as utilisé en supprimant les donnes sensibles si il y en a.
Je te joins le fichier source avec les deux essais
Salut,
Essaie avec le fichier joint, chez moi ca marche.
Si ca fonctionne, on regardera pour le numéro de dossier
Bonjour boltu, Jers19,
Les explications sont dans le code...
Sub ImportWord()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, Fichier As String
Dim i As Integer, j As Integer, p As Integer
p = 0
Chemin = "......." 'chemin où se trouve des fichiers
'----------------------------------------------------
'Boucle sur tous les fichiers doc du répertoire
'----------------------------------------------------
Fichier = Dir(Chemin & "*.docx") 'ou docx
Set WordApp = CreateObject("word.application")
Do While Len(Fichier) > 0
WordApp.Visible = True 'Word reste affiché pendant l'opération / Tu peux en mettant False masqué word pour + de rapidité
Set WordDoc = WordApp.Documents.Open(Chemin & "\" & Fichier) 'ouvre le document Word
For i = 1 To WordDoc.Tables(1).Rows.Count 'Tables(1) si le tableau à copier est le 1er du document
p = p + 1
For j = 1 To WordDoc.Tables(1).Columns.Count
valeur = Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(j).Cells(i).Range.Text)
' c'est ici que ce trouve le "manque du tableau"
' en fait la sructure du tableau word (ou plutot tel qu'il est rempli)
' fait qu'a partir de la 3ème ligne de données la colonne 1 est vide
If j = 1 And valeur = "" Then
' donc il faut dedoubler le test en verifiant si la colonne 2 est vide ou non
If Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(2).Cells(i).Range.Text) = "" Then
GoTo Suite
Else
' pour ecrire la suite du tableau
Cells(p, j).Value = valeur
End If
Else
Cells(p, j).Value = valeur
End If
Next j
Next i
Suite:
WordDoc.Close 'fermeture document Word
Fichier = Dir() 'récupére le nom du prochain fichier
Loop
WordApp.Quit 'fermeture session Word
End Sub
Merci pour vos réponses
Effectivement, cela marche avec ton fichier Jers19
C'est génial
Du coups, avant de réorganiser je souhaiterai maintenant ajouter avant chaque tableur le numéro de dossier ainsi que le nom et prénom de la personne
Sachant que dans le word les numero de dossiers ne sont pas toujours à jour, pas contre le titre est toujours à jour, au format Initiale du quartier (quelques lettres) - Nom Prénom- N° de dossier
Exemple:
CI - DUPONT Pierre - N°104
ou
ESPLA - DE MACHIN Daniel - N°313
Pense tu que ce soit possible de le faire?
Une dernière demande: serait ce possible de copier seulement quand la ligne n'est pas vide
(pour ne pas me retrouver à chaque fois avec un tableau de 10 lignes qui n'est rempli que sur deux lignes)
Merci!
Salut
en ce qui concerne le nom et le numéro de dossier. oui c'est possible sans pb.
je te répondrai ce soir.
en ce qui concerne les lignes vides, il faut que tu te référes à la réponse de NCC 1701.
qui vérifie si la colonne 1 et 2 sont vides.
Salut,
Voici le code avec la solution de NCC 1701 pour ne récupérer que les lignes non vides et avec l'ajout du numéro de dossier et du nom et prénom avant le tableau.
Sub ImportWord()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, Fichier As String, Valeur As String
Dim NumDossier As String, ID As String
Dim i As Integer, j As Integer, p As Integer
p = 0
Chemin = "P:\Donnees\Windows2012R2\Bureau\Travail sur IMC\" 'chemin où se trouve des fichiers
'----------------------------------------------------
'Boucle sur tous les fichiers doc du répertoire
'----------------------------------------------------
Fichier = Dir(Chemin & "*.docx")
Set WordApp = CreateObject("word.application")
WordApp.Visible = True 'Word reste affiché pendant l'opération / Tu peux en mettant False masqué word pour + de rapidité
Do While Len(Fichier) > 0
NumDossier = Left(Fichier, Len(Fichier) - 5) 'Nom du fichier sans l'extention
NumDossier = Trim(Right(NumDossier, Len(NumDossier) - InStr(1, NumDossier, "N°") - 1))
ID = Trim(Mid(Fichier, InStr(1, Fichier, "-") + 1, (Len(Fichier) - InStr(1, StrReverse(Fichier), "-")) - InStr(1, Fichier, "-")))
Set WordDoc = WordApp.Documents.Open(Chemin & "\" & Fichier)
p = p + 1
Cells(p, 1).Value = "Dossier N°: " & NumDossier
Cells(p, 2).Value = "Nom et Prénom : " & ID
For i = 1 To WordDoc.Tables(1).Rows.Count
p = p + 1
For j = 1 To WordDoc.Tables(1).Columns.Count
Valeur = Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(j).Cells(i).Range.Text)
If j = 1 And Valeur = "" Then
If Application.WorksheetFunction.Clean(WordDoc.Tables(1).Columns(2).Cells(i).Range.Text) = "" Then
GoTo Suite
Else
Cells(p, j).Value = Valeur
End If
Else
Cells(p, j).Value = Valeur
End If
Next j
Next i
Suite:
WordDoc.Close 'fermeture document Word
Fichier = Dir() 'récupére le nom du prochain fichier
Loop
WordApp.Quit 'fermeture session Word
End Sub
Bonjour (..)
@Jers19
Merci de prendre mon code en poursuite de ton travail, je crois que notre ami boltu n'avais pas vu cette proposition, qui me semble être la seule solution pour lire correctement son tableau depuis Word
Bonne poursuite dans ce fil, en tout cas je reste avec vous si tu veux bien, car "pour une fois" c'est un fil qui change un peu de l'ordinaire des questions...
Merci à vous deux pour vos réponses
La macro semble bien fonctionner
J'ai voulu rajouter des fichiers dans mon dossier source
Et un message d'appel s'affiche: "argument ou appel de procédure incorrect", du coups ca bloque à un moment
Dois je vérifier dans les nouveaux fichiers rajoutés s'il n'y a pas un truc qui ferais bugger?
(à priori j'ai regardé les 2 fichiers avant après ou la page s'arrête je ne vois pas d'anomalies)
Bonne journée!
Salut
A quel niveau le code plante t'il ?
NCC 1701
Pas de problème. Ravi de travailler en collaboration avec toi
Bonjour
Et surtout montre nous tes "ajouts"
Alors en gros en enlevant/ajoutant les fichiers, cela ne change rien, j'ai l'impression qu'il bug toujours vers la ligne 66.
En gros mes "ajouts" était de rajouter des fichiers du même type en plus.
J'ai d'abord fait la macro avec 150 documents, cela a marché
puis j'ai rajouté 70 documents et là il ne semble plus content...
EDIT: en fait tout bêtement un nom de fichier était au format différent, je suis ne train de voir mais cela semble mieux fonctionner
En fait, après avoir traqué les mauvais noms de fichiers, ca marche!
Pour la suite des documents, j'ai créé une nouvelle trame qui intègre un tableur excel, afin de pouvoir reporter directement les chiffres de l'imc de personnes dans une courbe de suivi
du coups la macro actuelle ne marche pas puisqu'elle va chercher les données dans le tableau d'après.
Serait ce possible de faire le même principe de macro avec le fichier qui suit?
Sachant qu'il y a 2 tableaux avec 2 courbes de croissance: une pour les filles, une pour les garçons, et ce serait bien de prendre les chiffres dans le tableau non vide ^^
SalutBoltu,
Tu peux essayer ça en considérant que chaque fichier ne comporte que deux objets.
Sub ImportWord()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Chemin As String, Fichier As String
Dim NumDossier As String, ID As String
Dim i As Integer, j As Integer, p As Integer
Dim MonTab()
p = 0
Chemin = "P:\Donnees\Windows2012R2\Bureau\Travail sur IMC\" 'chemin où se trouve des fichiers
'----------------------------------------------------
'Boucle sur tous les fichiers doc du répertoire
'----------------------------------------------------
Fichier = Dir(Chemin & "*.docx") 'ou docx
Set WordApp = CreateObject("word.application")
WordApp.Visible = True 'Word reste affiché pendant l'opération / Tu peux en mettant False masqué word pour + de rapidité
Do While Len(Fichier) > 0
NumDossier = Left(Fichier, Len(Fichier) - 5) 'Nom du fichier sans l'extention
NumDossier = Trim(Right(NumDossier, Len(NumDossier) - InStr(1, NumDossier, "N°") - 1))
ID = Trim(Mid(Fichier, InStr(1, Fichier, "-") + 1, (Len(Fichier) - InStr(1, StrReverse(Fichier), "-")) - InStr(1, Fichier, "-")))
Set WordDoc = WordApp.Documents.Open(Chemin & "\" & Fichier)
p = p + 1
Cells(p, 1).Value = "Dossier N°: " & NumDossier
Cells(p, 2).Value = "Nom et Prénom : " & ID
For i = 1 To 2
LastLigne = 0
WordDoc.InlineShapes(i).OLEFormat.Open
If Range("B2").Value <> "" Then
LastLigne = Range("B1").End(xlDown).Row
MonTab = ActiveWorkbook.Sheets(1).Range("A1:I" & LastLigne).Value
Exit For
End If
Next i
WordDoc.Close (False) 'fermeture document Word
If LastLigne <> 1 Then
For i = 1 To UBound(MonTab, 1)
For j = 1 To UBound(MonTab, 2)
Sheets(1).Cells(p + i, j).Value = MonTab(i, j)
Next j
Next i
p = p + i
End If
Fichier = Dir() 'récupére le nom du prochain fichier
Loop
WordApp.Quit 'fermeture session Word
End Sub
Merci pour ta réponse et pardon pour le retard de la mienne, j'avais pas mal de choses à boucler ces temps ci
Cela marche parfaitement bien, merci
Une petite demande en plus pour le nouveau type de fichier: serait ce possible de mettre le "Dossier N°: XX" sur une première colonne devant tous les autres, et de copier cette cellule devant chaque ligne de la personne concernée?
Cela permettrait de trier plus facilement les différents dossiers
(pour les fichiers ancienne version j'ai pu faire cela semi manuellement, donc ce serait juste bien pour les fichiers nouvelle version)