Discussion :

[djamat]

Bonjour,

J'ai un petit soucis sur une macro en VBA. Je suis débutant dans ce langage.
Je dois faire un tableau sur excel à l'aide de chaines caractères se trouvant dans un fichier Word ordinaire. Ces chaines de caractères sont facilement identifiable car elle se trouve dans différentes balises. cad:
document word:
blablablablablabla blablablablablabla [bal1] chaineàrecuperer chaineàrecuperer chaineàrecuperer [/bal1] blablablablablabla blablablablablabla.

J'ai voulu utiliser la fonction 'Find' (décrite dans un super tuto http://heureuxoli.developpez.com/off...-et-remplacer/ ) mais je n'y arrive pas.

Auriez vous une autre solution ? ou pouvez vous m’éclairer ?

[Invité]

Bonjour,
Je l’ai fait dans Word, adapte-le.

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
Type pose
Start As Long
End As Long
End Type
Function FindPosition(txt As String) As pose
With Selection.Find
    .Forward = True
    .ClearFormatting
    .MatchWholeWord = True
    .MatchCase = False
    .Wrap = wdFindContinue
    .Execute FindText:=txt
End With
 FindPosition.Start = Selection.Range.Start
FindPosition.End = Selection.Range.End
End Function

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Sub SubTest()
Dim P1 As pose
Dim P2 As pose
Dim P3 As pose
ActiveDocument.Range(1, 1).Select
P1 = Macro38("[bal1]")
P2 = Macro38("[/bal1]")
P3.Start = P1.End
P3.End = P2.Start
ActiveDocument.Range(P3.Start, P3.End).Select
End Sub

[Daniel.C]

Bonjour,

Il manque la partie récupérant les chaînes de caractères du document Word; cela dépend du document :

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub test3()
    Dim Txt As String, Deb As Integer, Fin As Integer, Tabl
    Txt = "blablablablablabla blablablablablabla [bal1] chaineàrecuperer chaineàrecuperer chaineàrecuperer [/bal1] blablablablablabla blablablablablabla."
    Deb = InStr(1, Txt, "[bal1]") + 7
    Fin = InStr(1, Txt, "[/bal1]") - 5
    Tabl = Split(Mid(Txt, Deb, Len(Txt) - Fin), " ")
    For Each Item In Tabl
        MsgBox Item
    Next Item
End Sub

[djamat]

Bonjour Claude,

Merci pour ta réponse, elle m'a beaucoup aidé. J’étais partie dans une mauvaise voie (dixit un de mes développeurs, il m'a soufflé le même raisonnement).

Merci encore

[djamat]

Bonjour,

Bon finalment ce nest pas tout a fait resolu, car jarrive bien à gerer la chaine de caractere (merci Daniel et non claude ).
"Il manque la partie récupérant les chaînes de caractères du document Word"
c'est la que ca bloque, cad:

j'arrive bien à recuperer mon fichier Word mais pas à l'attribuer à la varaible txt (par exemple) pour ensuite travailler sur la chaine de caractere.

Code :

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

1
2
3
4
5
6
7
8
 'le document Word est supposé fermé avant le lancement de la macro
    Fichier = "D:\Labo\fichier_soft.doc"
    'creation session Word
    Set WordApp = CreateObject("Word.Application")
    'pour que word reste masqué pendant l'opération
    WordApp.Visible = False
    'ouverture du fichier Word
    Set WordDoc = WordApp.Documents.Open(Fichier)

Comment puis je faire pour parcourir le fichier W afin de l'attribuer à ma variable txt ?

[Daniel.C]

Mets un fichier Word exemple en PJ - sans données confidentielles - qu'on puisse voir sa structure.

[djamat]

Bonjour Daniel,

Tu trouveras en attachement mon fichier épuré, l'original fait 20 pages avec 5 pages de présentation et ensuite que des pages comme la pièce jointe.
Les champs entre balises cad *********** sont à récupérés.

Merci pour votre aide,
Djamat

[djamat]

J'ai trouve ceci pour parcourir le fichier mais ca me donne pas de bon resultat cad msgbox devrait me sortir le premier mot mais en faite il me sort 'test Means' (present dans dans mon doc mais à la ligne 8 ou 9)

Code :

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

1
2
3
4
5
For i = 1 To WordDoc.Fields.Count
          If WordDoc.Fields(i).Result <> "" Then
            MsgBox WordDoc.Fields(i).Result.Text
          End If
    Next

Bon ca avance, jarrive maintenant à afficher mon contenu word dans mon fichier excel par paragraphe; me reste plus qu'a annalyser le contenu de chaque paragraphe pour chercher les balises

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
Dim tString As String, tRange As Object
Dim p As Long, r As Long
     r = 3 ' startrow for the copied text from the Word document
    With worddoc
            For p = 1 To .Paragraphs.Count
            Set tRange = .range(Start:=.Paragraphs(p).range.Start, _
            End:=.Paragraphs(p).range.End)
            tString = tRange.Text
            tString = Left(tString, Len(tString) - 1)
            ActiveSheet.range("A" & r).Formula = tString
            r = r + 1
            'End If
        Next p
 
        .Close ' close the document
    End With
    wordApp.Quit ' close the Word application
    Set worddoc = Nothing
    Set wordApp = Nothing
    'ActiveWorkbook.Saved = True
End Sub

[Daniel.C]

Il n'y a pas de balises "bal1" dans ton document. Sinon, utilise :

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
Sub test()
    Dim Paragraphe As Object, WordApp As Object, WordDoc As Object
    Dim Txt As String, Deb As Integer, Fin As Integer, Tabl, Ligne As Integer
 'le document Word est supposé fermé avant le lancement de la macro
    With Sheets("Feuil1")
        Fichier = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe\djamat fichier_soft2.doc"
        'creation session Word
        Set WordApp = CreateObject("Word.Application")
        'pour que word reste masqué pendant l'opération
        WordApp.Visible = False
        'ouverture du fichier Word
        Set WordDoc = WordApp.Documents.Open(Fichier)
        For Each Paragraphe In WordDoc.Paragraphs
            Txt = Paragraphe.Range.Text
            If InStr(1, Txt, "[bal1]") > 0 And InStr(1, Txt, "[/bal1]") > 0 Then
            Deb = InStr(1, Txt, "[bal1]") + 7
            Fin = InStr(1, Txt, "[/bal1]") - 5
            Tabl = Split(Mid(Txt, Deb, Len(Txt) - Fin), " ")
            For Each Item In Tabl
                Ligne = Ligne + 1
                .Cells(Ligne, 1) = Item
            Next Item
            End If
        Next Paragraphe
        WordDoc.Close
        WordApp.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End With
End Sub

[djamat]

Merci Daniel pour ton aide mais comment fais tu pour que chaque mot récupérer apparaisse dans la même cellule au lieu de les mettre dans 1 cellule différente à chaque fois ?

[Daniel.C]

Tu veux tout mettre dans la même cellule ? Mets-moi un classeur avec les bonnes balises en PJ.

[djamat]

-> le .doc, dans lequel je dois recuperer tous ce qu'il y a entre les balises puis mettre les differentes chaines dans une cellule differentes, exempl:
[objective]debut*****fin[/objective]
et retrouver dans la cellule A1 du .xlsm "debut****fin"
et faire de meme avec les autres balises dans une autre cellule

[Daniel.C]

Tu compliques le problème. D'un type de balise, on passe à n types. Tu n'as pas une liste, ça simplifierait quand même.

[djamat]

oui je sais mais on m'en rajoute au fur et à mesure

Maintenant cest bon la liste est fixé:
[OBJECTIVE] - [REMINDER] - [TRACE] - [CHECK] - [LOG] - [SUBTEST]

En faite c'est un fichier doc comme joint dans mon message ci dessus avec plusieurs fois le même tableau(dans le fichier on en voit qu'un seul)

Au debut je voulais stocker chaque balise dans un tableau pour ensuite les appeler en 'condition' mais le soucis est que lorsque je recupere la chaine de caractere, mon nombre de caractere change selon la balise et du coup cela donne n'importe quoi.

et l'objectif final est de tout mettre dans un tableau avec tous les commentaires de [objective] par exemple dans la meme colonne.

[Daniel.C]

Essaie :

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
Sub test()
    Dim Paragraphe As Object, WordApp As Object, WordDoc As Object
    Dim Txt As String, Deb As Integer, Fin As Integer, Ligne As Integer
    Dim Col As Integer, Bal As String
 'le document Word est supposé fermé avant le lancement de la macro
    With Sheets("Feuil1")
        Fichier = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe\djamat\djamat fichier_soft2.doc"
        'creation session Word
        Set WordApp = CreateObject("Word.Application")
        'pour que word reste masqué pendant l'opération
        WordApp.Visible = False
        'ouverture du fichier Word
        Set WordDoc = WordApp.Documents.Open(Fichier)
        For Each Paragraphe In WordDoc.Paragraphs
            Txt = Paragraphe.Range.Text
            Deb = InStr(1, Txt, "[")
            Fin = InStr(1, Txt, "]")
            If Deb > 0 And Fin > 0 Then
                Bal = Mid(Txt, Deb + 1, Fin - 2)
                If InStr(1, Txt, "[/" & Bal & "]") > 0 Then
                    Deb = InStr(1, Txt, "[" & Bal & "]") + Len("[" & Bal & "]")
                    Fin = InStr(1, Txt, "[/" & Bal & "]") - Len("[/" & Bal & "]")
                    Txt = Mid(Txt, Deb, Fin)
                    Set c = .Rows(1).Find(Bal, , , xlWhole)
                    If c Is Nothing Then
                        If .Cells(1, 1) = "" Then
                            Col = 1
                        Else
                            Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
                        End If
                        .Cells(1, Col) = Bal
                    Else
                        Col = c.Column
                    End If
                    .Cells(2, Col) = .Cells(2, Col) & Txt
                End If
            End If
        Next Paragraphe
        WordDoc.Close
        WordApp.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End With
End Sub

[djamat]

Tu es vraiment bon et en plus le code est clair ! merci

Une petite remarque: comme tu as pu voir dans le fichier word il est possible de retrouver 2 fois la meme balise (exemple:[check]) et avec ton code il rajoute le texte à la suite de l'autre alors qu'il faudrait mettre le 2eme commentaire dans la cellule du dessous mais toujours dans la meme colonne.(exemple colonne check).
Comment faire ?

[Daniel.C]

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
Sub test()
    Dim Paragraphe As Object, WordApp As Object, WordDoc As Object
    Dim Txt As String, Deb As Integer, Fin As Integer, Ligne As Integer
    Dim Col As Integer, Bal As String
 'le document Word est supposé fermé avant le lancement de la macro
    With Sheets("Feuil1")
        Fichier = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe\djamat\djamat fichier_soft2.doc"
        'creation session Word
        Set WordApp = CreateObject("Word.Application")
        'pour que word reste masqué pendant l'opération
        WordApp.Visible = False
        'ouverture du fichier Word
        Set WordDoc = WordApp.Documents.Open(Fichier)
        For Each Paragraphe In WordDoc.Paragraphs
            Txt = Paragraphe.Range.Text
            Deb = InStr(1, Txt, "[")
            Fin = InStr(1, Txt, "]")
            If Deb > 0 And Fin > 0 Then
                Bal = Mid(Txt, Deb + 1, Fin - 2)
                If InStr(1, Txt, "[/" & Bal & "]") > 0 Then
                    Deb = InStr(1, Txt, "[" & Bal & "]") + Len("[" & Bal & "]")
                    Fin = InStr(1, Txt, "[/" & Bal & "]") - Len("[/" & Bal & "]")
                    Txt = Mid(Txt, Deb, Fin)
                    Set c = .Rows(1).Find(Bal, , , xlWhole)
                    If c Is Nothing Then
                        If .Cells(1, 1) = "" Then
                            Col = 1
                        Else
                            Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
                        End If
                        .Cells(1, Col) = Bal
                    Else
                        Col = c.Column
                    End If
                    .Cells(.Rows.Count, Col).End(xlUp).Offset(1) = Txt
                End If
            End If
        Next Paragraphe
        WordDoc.Close
        WordApp.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End With
End Sub

[djamat]

ReBonjour Daniel,

Tout d'abord encore un grand merci pour ton aide.
Et comme je suis quelqu'un de ch****, j'aimerai un petit dernier service:

Comme ce code sera appelé plusieurs fois en fonction des objectifs, j'aimerai que à chaque nouveau tableau Word il y ai une barre de couleur (par exemple interior.colorindex = 3) afin de bien différencier les éléments récupérer (+une fusion de cellule sur l'objectif).
Tu trouveras en attachement mon souhait.

Promis ce sera ma dernière demande de codage car la je m'écarte du topic d'origine.

PS: si ça te dérange pas je vais re-poster ton code avec du commentaire afin de savoir si j'ai bien tout compris

[djamat]

jia besoin de bien comprendre le code afin de progresser, au cas ou si tu vois une anomalie ou un comment à rajouter pas de soucis

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
For Each Paragraphe In WordDoc.Paragraphs
         'pour chaque paragraphe on verifie si il y a un [
         Txt = Paragraphe.Range.Text
         Deb = InStr(1, Txt, "[")
         Fin = InStr(1, Txt, "]")
 
         'deb & fin seront toujours superieur à 0 si txt n'a pas de [
         If Deb > 0 And Fin > 0 Then
            'bal recupere le nom de la balise, +1 pour le [ et -2 pour /], donc bal=objective par exemple
            Bal = Mid(Txt, Deb + 1, Fin - 2)
 
            If InStr(1, Txt, "[/" & Bal & "]") > 0 Then
            'deb: calcule le nombre de caractere selon la balise cad "[REMINDER] "=10+1espace
            'fin: compte le nombre de caractere avant la balise avant [/
            'txt: recupere le resultat final
               Deb = InStr(1, Txt, "[" & Bal & "]") + Len("[" & Bal & "]")
               Fin = InStr(1, Txt, "[/" & Bal & "]") - Len("[/" & Bal & "]")
               Txt = Mid(Txt, Deb, Fin)
               'entete de colonne cad bal
               Set c = .Rows(1).Find(Bal, , , xlWhole)
 
               If c Is Nothing Then
               'si la cellule A1 est vide alors colonne prends 1 sinon elle s'incremente;
                  If .Cells(1, 1) = "" Then
                  '1seul passage
                     Col = 1
                  Else
                     Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
                  End If
                  'on copie l'entete dans une cellule
                  .Cells(1, Col) = Bal
               Else
                  'on copie l'entete dans une cellule
                  Col = c.Column
               End If
               'et on place la chaine de caractere dans une cellule differente
               .Cells(.Rows.Count, Col).End(xlUp).Offset(1) = Txt
 
            End If
         End If
 
      Next Paragraphe

[Daniel.C]

C'est bien ça; j'ai corrigé deux trois petits détails.

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
Sub test()
    Dim Paragraphe As Object, WordApp As Object, WordDoc As Object
    Dim Txt As String, Deb As Integer, Fin As Integer, Ligne As Integer
    Dim Col As Integer, Bal As String
 'le document Word est supposé fermé avant le lancement de la macro
    With Sheets("Feuil1")
        Fichier = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe\djamat\djamat fichier_soft2.doc"
        'creation session Word
        Set WordApp = CreateObject("Word.Application")
        'pour que word reste masqué pendant l'opération
        WordApp.Visible = False
        'ouverture du fichier Word
        Set WordDoc = WordApp.Documents.Open(Fichier)
    For Each Paragraphe In WordDoc.Paragraphs
         'pour chaque paragraphe on verifie si il y a un [ et un ]
         Txt = Paragraphe.Range.Text
         Deb = InStr(1, Txt, "[")
         Fin = InStr(1, Txt, "]")
 
         'deb & fin seront toujours superieur à 0 si txt n'a pas de [
         If Deb > 0 And Fin > 0 Then
            'bal recupere le nom de la balise, +1 pour le [ et -2 pour /], donc bal=objective par exemple
            Bal = Mid(Txt, Deb + 1, Fin - 2)
            'vérification de la présence d'une balise de fin
            If InStr(1, Txt, "[/" & Bal & "]") > 0 Then
            'deb: calcule le nombre de caractere selon la balise cad "[REMINDER] "=10+1espace
            'fin: compte le nombre de caractere avant la balise avant [/
            'txt: recupere le resultat final
               Deb = InStr(1, Txt, "[" & Bal & "]") + Len("[" & Bal & "]")
               Fin = InStr(1, Txt, "[/" & Bal & "]") - Len("[/" & Bal & "]")
               Txt = Mid(Txt, Deb, Fin)
               'entete de colonne cad bal
               Set c = .Rows(1).Find(Bal, , , xlWhole)
 
               If c Is Nothing Then
               'si la cellule A1 est vide alors colonne prends 1 sinon elle s'incremente;
                  If .Cells(1, 1) = "" Then
                  '1seul passage
                     Col = 1
                  Else
                     Col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
                  End If
                  'on copie l'entete dans une cellule
                  .Cells(1, Col) = Bal
               Else
                  'Si la balise existe déjà sur la feuille, on récupère sa colonne
                  Col = c.Column
               End If
               'et on place la chaine de caractere dans la première cellule vide dans la colonne
               .Cells(.Rows.Count, Col).End(xlUp).Offset(1) = Txt
 
            End If
         End If
 
      Next Paragraphe
      'ajout d'une ligne de couleur
      Rows(Ligne + 1).Interior.ColorIndex = 3
        WordDoc.Close
        WordApp.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End With
End Sub