Discussion :

[lemzo84]

Bonjour,

J'ai un fichier Word de plusieurs pages qui contient le mot "Reference:" suivi d'une numérotation alpha numérique. Je voudrais qu'à chaque fois que ce mot est rencontré, Word puisse me générer un document enregistré avec la numérotation alpha numérique.
Exemple: J'ai un document de 5 pages. Sur la première, j'ai le Référence: 123456789AB avec du texte. Ensuite sur la 4ie page, j'ai Référence: 845645665ZK. Au finish, j'aurai 2 documents générés, l'un nommé 123456789AB.doc de 3 pages et le second nommé 845645665ZK.doc de 2 pages.
J'espèque l'example est clair. J'ai essayé de modifier plusieurs codes VBA vus sur le net mais sans succès. (https://www.msofficeforums.com/mail-...ps-tricks.html ou encore https://answers.microsoft.com/en-us/...d-90fd27f1c6a3).
Quelqu'un aurait-il une idée ou un script qui puisse faire cela.
Merci.

[Invité]

Bonjour,

Regardez cette discussion : https://www.developpez.net/forums/d2...document-word/

Les /// dont il est question sont à remplacer par Référence.

[lemzo84]

Bonjour Eric,

J'ai effectué le remplacement et les sous documents sont crées. Cependant, les documents créés ont le préfixe AAA, alors que je souhaite le numéro situé apres la chaine de caractère "Reference:" serve de nom de fichier. Example:

*Document Word original contient:

Reference: 165418944AB
Structure: Alpha1
Contenu : Beta1

Reference: 8784646556CD
Structure : Alpha2
Contenu : Beta2
Structure : Alpha2-1
Contenu : Beta2-1

Reference: 56444564SF
Structure : Alpha3
Contenu : Beta3


Il y aura donc 3 documents générés nommés 165418944AB.doc, 8784646556CD.doc et 56444564SF.doc

165418944AB.doc va contenir:
Reference: 165418944AB
Structure: Alpha1
Contenu : Beta1

8784646556CD.doc va contenir:
Reference: 8784646556CD
Structure : Alpha2
Contenu : Beta2
Structure : Alpha2-1
Contenu : Beta2-1

56444564SF.doc
Reference: 56444564SF
Structure : Alpha3
Contenu : Beta3

Voici le code que j'ai utilisé:

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 test2()
 
Dim DocEnCours As Document, NouveauDoc As Document
Dim MatriceRanges() As Variant
Dim I As Long, IndexMatrice As Long, CaractereDebut As Long
Dim StrFilename As String
 
     Set DocEnCours = ActiveDocument
     With DocEnCours
 
          IndexMatrice = 0
          CaractereDebut = 1
          StrFilename = "AAA"
 
          For I = 1 To .Paragraphs.Count
 
              If InStr(1, .Paragraphs(I).Range, "Reference: ", vbTextCompare) > 0 Then
                 .Paragraphs(I - 1).Range.Select
                 Selection.EndKey unit:=wdLine
 
                 Selection.HomeKey unit:=wdStory, Extend:=wdExtend
                 ReDim Preserve MatriceRanges(1, IndexMatrice)
                 MatriceRanges(1, IndexMatrice) = Selection.Characters.Count
 
                 If IndexMatrice > 0 Then
                    MatriceRanges(0, IndexMatrice) = CaractereDebut
                 End If
 
                 .Paragraphs(I + 1).Range.Select
                 Selection.HomeKey unit:=wdLine
                 Selection.HomeKey unit:=wdStory, Extend:=wdExtend
                 CaractereDebut = Selection.Characters.Count
 
                 IndexMatrice = IndexMatrice + 1
               End If
          Next I
 
 
          For IndexMatrice = LBound(MatriceRanges, 2) To UBound(MatriceRanges, 2)
 
              Selection.HomeKey unit:=wdStory, Extend:=wdExtend
              .Range.Select
              Selection.SetRange MatriceRanges(0, IndexMatrice), MatriceRanges(1, IndexMatrice)
 
 
              Selection.Range.Copy
              Set NouveauDoc = Documents.Add
              With NouveauDoc
                   .Range.Paste
                   .SaveAs ThisDocument.path & "\" & StrFilename & Format(IndexMatrice + 1, "000")
                   .Close True
              End With
              Set NouveauDoc = Nothing
 
          Next IndexMatrice
 
     End With
 
     Set DocEnCours = Nothing
 
 
End Sub

Merci encore pour vos suggestions.

[lemzo84]

J'attache le fichier test.doc pour ceux qui veulent contribuer à la réflexion.
Merci.

[Invité]

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 test2()
 
Dim DocEnCours As Document, NouveauDoc As Document
Dim MatriceRanges() As Variant
Dim I As Long, IndexMatrice As Long, CaractereFin As Long
Dim StrFilename As Variant
 
     Set DocEnCours = ActiveDocument
     With DocEnCours
 
          IndexMatrice = 0
          CaractereFin = .Characters.Count
 
          For I = .Paragraphs.Count To 1 Step -1
 
              If InStr(1, .Paragraphs(I).Range, "Reference: ", vbTextCompare) > 0 Then
 
                 .Paragraphs(I).Range.Select
                 StrFilename = Trim(Split(.Paragraphs(I).Range.Text, ":")(1))
                 StrFilename = Mid(StrFilename, 1, Len(StrFilename) - 1)
                 Selection.HomeKey unit:=wdLine
 
                 Selection.HomeKey unit:=wdStory, Extend:=wdExtend
                 ReDim Preserve MatriceRanges(2, IndexMatrice)
                 MatriceRanges(0, IndexMatrice) = Selection.Characters.Count
                 MatriceRanges(1, IndexMatrice) = CaractereFin
                 MatriceRanges(2, IndexMatrice) = StrFilename
                 CaractereFin = MatriceRanges(0, IndexMatrice) - 1
 
                 IndexMatrice = IndexMatrice + 1
 
               End If
          Next I
 
 
          For IndexMatrice = LBound(MatriceRanges, 2) To UBound(MatriceRanges, 2)
 
              If MatriceRanges(2, IndexMatrice) <> "" Then
              Selection.HomeKey unit:=wdStory, Extend:=wdExtend
              .Range.Select
              Selection.SetRange MatriceRanges(0, IndexMatrice), MatriceRanges(1, IndexMatrice)
 
 
              Selection.Range.Copy
              Set NouveauDoc = Documents.Add
              With NouveauDoc
                   .Range.Paste
                   .SaveAs DocEnCours.Path & "\" & MatriceRanges(2, IndexMatrice)
                   .Close True
              End With
              Set NouveauDoc = Nothing
 
              End If
 
          Next IndexMatrice
 
     End With
 
     Set DocEnCours = Nothing
 
 
End Sub