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
| Sub RecupDataBalise()
Dim A$
Dim reponse
Dim DOC As Object 'Word.document
Dim T()
Dim pos&
Dim cpt&
reponse = Application.GetOpenFilename("Documents Word (*.doc), *.doc")
If reponse = False Then Exit Sub
'--- Ouvre le fichier Word sans qu'il soit visible
Set DOC = GetObject(reponse)
'--- Récupère tout le texte du fichier dans une variable de type String
A$ = DOC.Range.Text
'--- Ferme le fichier Word
DOC.Close
Set DOC = Nothing
'--- Si il n'y a aucune occurence de "[" alors on quitte la macro
If InStr(1, A$, "[") = 0 Then Exit Sub
'--- On recherche les "[" et les "]" pour définir leurs positions
'--- puis on coupe les sous-chaînes qui nous intéressent
'--- Mettez vous en mode pas à pas (F8) pour surveiller les
'--- valeurs de A$ et de pos&
Do Until InStr(1, A$, "]") = 0
pos& = InStr(1, A$, "[")
A$ = Mid(A$, pos + 1)
pos& = InStr(1, A$, "]")
cpt& = cpt& + 1
'--- On met les extractions dans un tableau bidimensionné
'--- ATTENTION seule la dernière dimension peut être redimensionnée
ReDim Preserve T(1 To 2, 1 To cpt&)
'--- Les 00x ---
T(1, cpt&) = Mid(A$, 1, pos& - 1)
A$ = Mid(A$, pos& + 1)
pos& = InStr(1, A$, "[")
'--- Le texte qui nous intéresse
T(2, cpt&) = Trim(Mid(A$, 1, pos& - 1))
A$ = Mid(A$, pos& + Len(T(1, cpt&)) + 2)
Loop
'--- On a joute une nouvelle feuille
Sheets.Add
'--- On inscrit ce qui a été trouvé dans la nouvelle feuille
'--- après avoir transposé le tableau T
'--- Il y a nécessité de transposer pour obtenir des lignes sur 2 colonnes
'--- et non 2 lignes sur des colonnes
'--- Voir la remarque ci-dessus (ATTENTION seule la dernière dimension peut être redimensionnée)
Range(Cells(1, 1), Cells(UBound(T, 2), 2)) = _
Application.WorksheetFunction.Transpose(T)
End Sub |
