Discussion :

[veromisoto]

Bonjour

J'aimerais importer via macro l'entête d'un fichier word vers une feuille excel . (à savoir texte entête du fichier word ci-joint " Livre des bovins du 01-04-18 31-03-19") Texte qui diffère d'un client à un autre.

J'ai également un souci avec tableaux word qui n'ont pas la même configuration. Aussi je veux via une macro excel intégrer une colonne dans certains tableaux du fichier word . Voir fichier Word tableau 1 et tableau 2 pas la même configuration, la bonne étant tableau 1. Sans doute ajouter colonne dans table 2 entre TR et date de nais.
En pièce jointe les fichiers
Merci de votre aide

[Menhir]

J'aimerais importer via macro l'entête d'un fichier word vers une feuille excel . (à savoir texte entête du fichier word ci-joint " Livre des bovins du 01-04-18 31-03-19") Texte qui diffère d'un client à un autre.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range("A1").Value = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text

A lire : https://docs.microsoft.com/fr-fr/off...d.headerfooter

Pour ce qui est du reste, n'ouvrant pas les fichiers joints, je ne peux pas t'aider.
https://www.developpez.net/forums/d8...s-discussions/

[veromisoto]

Bonjour

J'ai testé la solution de Menhir sans succès. Mais j'ai sans doute mal expliqué la problématique.

Je veux copier via macro excel l'entête d'une page word vers une feuille excel. (Je travaille sur excel 97/2003)
Je veux également par macro excel intégrer une colonne dans un tableau word si cellule spécifique dans ce même tableau word a telle valeur.

Ce sont les deux derniers points à régler et le petit outil est ficelé. Depuis x heures j'essaie mais sans succès.

Merci de m'accompagner

[Menhir]

J'ai testé la solution de Menhir sans succès.

Premièrement, tu devrais répondre dans ton sujet initial.
Parce que ta demande telle qu'elle est formulée ici est incompréhensible.

Deuxièmement, si tu ne montres pas ce que tu as essayé de faire et ce qui ne fonctionne pas comme tu le désires, il n'est pas possible de t'indiquer comment le corriger.

[veromisoto]

Bonjour

Pas habitué à ce site, sans aucun doute maladroit, milles excuses.


J'aimerais,malgré tout, avoir une aide pour finaliser un petit programme sous excel 1997/2003 qui récupére les données de fichier client (suivi de troupeau animaux) sous word.
Il me reste deux points à régler.
1er* Récupération de l'en-tête sur fichier word pour le copier sur feuille excel (voir ci-dessous le bout de code, en majuscule le code mais ne fonctionne pas)

2ème* je copie selon les clients de 30 à 50 tableaux de 12 à 14 lignes chacun. Sur certains tableaux , il manque une colonne. J'ai également essayé plusieurs instructions trouvées sur le forum pour insérer une colonne selon conditions de valeur de cellule dans fichier word mais sans succès. Il y a sans doute une solution mais je n'y arrive pas. Peut-on imaginer compter les colonnes de chaque tableaux et si le nombre est différent du tableau idéal, en rajouter une.

(en fin de message exemple de tableau d'import de donnés dans lequel à partie d'excel, je souhaite intégrer une colonne en dessous de P )

Si quelqu'un peut m'accompagner, ce serait super

D'avance merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Sub importpilot()
 
 
 
 
Dim Fichier As Variant, lig As Integer, Lig1 As Integer, lig2 As Integer, Lig3 As Integer, Lig4 As Integer, Lig5 As Integer, Lig6 As Integer, Lig7 As Integer, Lig8 As Integer, Lig9 As Integer
 
 
    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    Fichier = Application.GetOpenFilename(FileFilter:="word Files (*.docx*), *.docx", Title:="Sélectionnez le fichier *.*")
 
 
    If Not Fichier = "Faux" Then
        lig = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig1 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        lig2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig3 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig4 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig5 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig6 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig7 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig8 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Lig9 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
 
 
        importwordpilot Fichier, lig, Lig1, lig2, Lig3, Lig4, Lig5, Lig6, Lig7, Lig8, Lig9
    End If
'
 
'
End Sub
 
Sub importwordpilot(NDF As Variant, lig As Integer, Lig1 As Integer, lig2 As Integer, Lig3 As Integer, Lig4 As Integer, Lig5 As Integer, Lig6 As Integer, Lig7 As Integer, Lig8 As Integer, Lig9 As Integer)
'
Dim WordApp As Object, WordDoc As Object, WSel As Object
Dim t() As String
Dim ws As Worksheet
Dim wa As Worksheet
Dim wc As Worksheet
 
 
Dim wb As Workbook
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1) * *'on sauvegarde dans la 1re feuille
    Set wa = wb.Sheets(2) *'on sauvegarde dans la 2eme feuille
    Set wc = wb.Sheets(3) *'on sauvegarde dans la 2eme feuille
    Dim i As Integer, p As Integer, j As Integer, a As Integer, ii As Integer, pp As Integer, jj As Integer, e As Integer, ppp As Integer, iii As Integer, jjj As Integer, pppp As Integer, iiii As Integer, jjjj As Integer, ppppp As Integer, iiiii As Integer, jjjjj As Integer, pppppp As Integer, iiiiii As Integer, jjjjjj As Integer, ppppppp As Integer, iiiiiii As Integer, jjjjjjj As Integer
    Dim ia As Integer, pa As Integer, ja As Integer, ib As Integer, pb As Integer, jb As Integer, ic As Integer, pc As Integer, jc As Integer
 
 
    a = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 * '1re ligne où on va écrire les données dans le fichier Excel feuille 1
    e = wa.Range("A" & Rows.Count).End(xlUp).Row + 1 * '1re ligne où on va écrire les données dans le fichier Excel 2eme feuille
    Sheets("Param").Range("a1").ClearContents
 
p = 2
 
 
    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.documents.Open(NDF, ReadOnly:=False)
 
 
 
               ' COPIE N° élevage
        WordApp.Selection.HomeKey unit:=6 * * * * * * *'Retourne au début du fichier Word
        WordApp.Selection.Find.ClearFormatting * * * * 'on "vide la mémoire" de la fonction Recherche
        WordApp.Selection.Find.Execute Sheets("Param").Range("a16").Value
 
 
        WordApp.Selection
        Set WSel = WordApp.Selection.Range.Copy
        Sheets("Param").Range("a1").PasteSpecial (xlPasteValues) 'colle la valeur dana la cellule
 
    If Sheets("Param").Range("a1") = "" Then
    MsgBox " Attention soit le n° d'élevage que vous avez saisi n'est pas le bon, soit le fichier provenant de Pilot'élevage n'est pas le bon !"
 
    End If
 
CI-DESSOUS, J'AI ESSAYE CE CODE ET BIEN D'AUTRES SANS RESULTAT POUR COPIER L'EN-TETE
DU DOCUMENT WORD DANS LA FEUILLE "Param" D'EXCEL.*
 
With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
 If .Range.Text <> vbCr Then
Sheets("Param").Range("A25") = .Range.Text
 
 End If
End With
 
FIN D ESSAI
 
 
 
 
 
 Sheets("Param").Range("c1") = 1
 
 
'copie tableau 1
    With WordApp.Visible = False
 
    If WordDoc.Tables(1) = False Then
 
 
    WordDoc.SaveAs "C:\Livre_bovins_tampon.docx"
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    Exit Sub
    Else
 
 
PEUT -ÊTRE ICI LE BOUT DE CODE POUR LE DEUXIEME PROBLEME D'INSERTION DE COLONNE
 
       For i = 3 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)
 
                    With WordDoc.Tables(1)
            t = Split(.Cell(p, 1).Range.Text, Chr(13))*
 
 
 
             ws.Cells(lig, "a").Value = t(0)
 
            t = Split(.Cell(p, 2).Range.Text, Chr(13))**
 
 
 
            ws.Cells(lig, "b").Value = t(0)
 
            t = Split(.Cell(p, 3).Range.Text, Chr(13))
            ws.Cells(lig, "c").Value = t(0)
 
            t = Split(.Cell(p, 4).Range.Text, Chr(13))
            ws.Cells(lig, "d").Value = t(0)
 
             t = Split(.Cell(p, 5).Range.Text, Chr(13))
            ws.Cells(lig, "e").Value = t(0)
 
 
             t = Split(.Cell(p, 8).Range.Text, Chr(13))
            ws.Cells(lig, "f").Value = t(0)
 
              t = Split(.Cell(p, 13).Range.Text, Chr(13))
            ws.Cells(lig, "g").Value = t(0)
 
               t = Split(.Cell(p, 10).Range.Text, Chr(13))
            ws.Cells(lig, "h").Value = t(0)
 
               t = Split(.Cell(p, 11).Range.Text, Chr(13))
            ws.Cells(lig, "i").Value = t(0)
 
               t = Split(.Cell(p, 12).Range.Text, Chr(13))
            ws.Cells(lig, "j").Value = t(0)
 
        End With
 
        Next j
        lig = lig + 1
    Next i
 copiecentral 'macro* intermédiaire
 
    If WordDoc.Tables(2) = False Then
    WordDoc.SaveAs "C:\Livre_bovins_tampon.docx"
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    Exit Sub
    Else
 
 
 
   '2eme tableau

etc...

il peut y avoir 60 tableaux à extraire comme celui-ci


ANIMAUX PRESENTS (335)

N° National	N° Trav.	Nom	S.	TR		Date naiss.	Naisseur	N° mère	Entrée	Sortie	TA.
				S M P				N° père	Date - Cause Provenance	Date - Cause Acheteur
FR 4906586114	6114	HYNAMIQUE	F	66	66	23/05/2012	FR 49010108	FR 4906585755 IA	23/05/12 - N		VL
FR 4906586117	6117	HYSPIONNE	F	66	66	05/06/2012	FR 49010108	FR 4906585844 IA	05/06/12 - N		VL
FR 4906586124	6124	HYMOTIVE	F	66	66	08/07/2012	FR 49010108	FR 4906585874 IA	08/07/12 - N		VL
FR 4906586168	6168	IBIZA	F	66	66	16/02/2013	FR 49010108	FR 4906586006 IA	16/02/13 - N		VL