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

88forum-imc.zip (753.49 Ko)

Salut,

Essaie avec le fichier joint, chez moi ca marche.

Si ca fonctionne, on regardera pour le numéro de dossier

134forum-imc.xlsm (14.77 Ko)

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)

Rechercher des sujets similaires à "creer macro fichiers word"