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 |
