Discussion :

[BillBoket]

Bonjour,
j'ai un dossier de 5000 modèles d'ordonnance médecin en fichiers Word (.dot).
Au début de chaque fichier il y a plusieurs lignes vides (retours charriots).
Pour chaque fichier, je dois supprimer les lignes vides en début de fichier jusqu'à la première ligne non vide.

J'ai trouvé ça sur le net mais ça ne donne pas le résultat escompté :

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
With Selection.Find
 
          .ClearFormatting
 
          .Forward = True
 
          .MatchCase = False
 
          .Wrap = wdFindContinue
 
          .Text = "^p"
 
          .Execute
 
          Do While .Found = True
 
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
 
            Selection.Delete Unit:=wdCharacter, Count:=1
 
            .Execute
 
       Loop
 
 
 
  End With

Merci de votre aide !

[Heureux-oli]

Bonjour et bienvenue sur les forums Office de DVP.


La solution n'est pas de passer par une recherche !

Selon moi, il fait parcourir tous les paragraphes et mesurer leur longueur, si il ne contient rien, on supprime.
On peut boucler jusqu'à rencontrer un paragraphe contenant du texte.


Pour boucler, on va travailler sur la collection des paragraphes.

Code :

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

1
2
3
4
5
6
7
8
9
Dim pAra As Paragraph
 
For Each pAra in ActiveDocument.Paragraphs
   If len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
     Exit Sub
   End If
Next pAra

Si tu as beaucoup de document, on peut boucler sur les documents aussi !

[BillBoket]

Bonjour et merci Heureux-oli, moi aussi je suis heureux car ton code marche !

Et maintenant, comment boucler sur 5000 fichiers dans un seul dossier?

Bonjour et bienvenue sur les forums Office de DVP.

Code :

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

1
2
3
4
5
6
7
8
9
Dim pAra As Paragraph
 
For Each pAra in ActiveDocument.Paragraphs
   If len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
     Exit Sub
   End If
Next pAra

Si tu as beaucoup de document, on peut boucler sur les documents aussi !

[Heureux-oli]

Voilà comment on boucle sur les fichiers d'un répertoires.

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
 
 
Sub boucleFichier()
Dim oFs As New FileSystemObject
Dim oDir As Folder
Dim oFil As File
Dim oDia As FileDialog
Dim stRep As String
 
 
Set oDia = Application.FileDialog(msoFileDialogFolderPicker)
oDia.Show
stRep = oDia.SelectedItems(1)
Set oDir = oFs.GetFolder(stRep)
For Each oFil In oDir.Files
 
Debug.Print oFil.Name
Next oFil
 
 
 
End Sub

[BillBoket]

merci Heureux=oli tu es un chou j'avais bien compris que c'était pas le bon jour...mais mon client a besoin de moi le w-e...
je m'en vais tester ton code et te dirai...

(entre parenthèse j'essaie bien de comprendre le VB, mais pour l'instant il n'y a que l'Ada qui me parle doucement dans mon oreille sensible...)
Merci encore

[Heureux-oli]

J'ai oublié de te dire qu'il faut ajouter une bibliothèque dans ton projet VBA.
Dans le VBE
Outils
Reférences
Microsoft Scritping Runtime.

Il faut aussi libérer les objets.

Code :

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

1
2
Set oFs = Nothing
....

Mais tu n'as toujours pas le moyen de les ouvrir en Word et d'effectuer ta suppression.

Pour les ouvrir en Word, dans la boucle des fichiers, il faut affecter la variable à un objet.

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
Sub boucleFichier()
Dim oFs As New FileSystemObject
Dim oDir As Folder
Dim oFil As File
Dim oDia As FileDialog
Dim stRep As String
Dim oDoc as Document
 
 
 
Set oDia = Application.FileDialog(msoFileDialogFolderPicker)
oDia.Show
stRep = oDia.SelectedItems(1)
Set oDir = oFs.GetFolder(stRep)
For Each oFil In oDir.Files
 
set oDoc = Documents.Open (stRep & oFil.Name)
' La boucle de remplacement
Dim pAra As Paragraph
 
For Each pAra in oDoc.Paragraphs
   If len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
     Exit Sub
   End If
Next pAra
 
oDoc.Close
Set oDoc = Nothing
 
Next oFil
 
Set oFs = Nothing
set oDir = Nothing
set oDia = Nothing 
 
End Sub

[BillBoket]

ok merci de tes précisions je commençais à me torturer la tronche

(j'avais trouvé pour M$ Scripting Runtime mais pas pour le reste)

je viens de tester ton nouveau code qui marche en partie mais il y a pas mal de pb: il efface tout dans le fichier (?), il n'enregistre pas au format Word, dialogues de conversion de formats à la fermeture, etc.

C'est plus difficile que ce que je ne le pensais. D'autre part, il faut y intégrer une fonction d'effacement conditionnel de ligne dont je ne t'avais pas parlé, car je l'avais déjà récupérée sur le net...

Bref, voilà ce que je te propose:
Actuellement, la macro fonctionne sur un fichier Word ouvert.
Ca serait intéressant de mettre en place pour 5000 fichiers, mais je suis sûr que tu as d'autres choses à faire, et que je n'ai pas envie de passer le W-E à ça, n'étant pas développeur.
Demain je vais aller sur la machine du client équipé MacOs 10.5 et je vais lui coller ma macro dans son Word, puis enregistrer un script à la main avec Automator que je commence à connaitre un peu, qui ouvrira chaque fichier Word, lancera notre macro, le fermera en enregistrant les modifs, puis ouvrira le suivant, etc.
Si jamais ça foire pour une raison ou pour une autre, je reviendrai à la charge sur ce gentil forum, et on prendra le taureau par les couilles.
En attendant voici la macro "mono-fichier" actuellement fonctionnelle, et sur ce, bon Week=End et un grand merci à toi Heureux-oli !

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
 
Sub MiseEnForme()
'
' Macro créée le 26/04/2008 par Heureux=Oli et BillBoket
'
' 
'
'
' Ici tout un bordel surement pas optimisé (!)
' destiné à rechercher les lignes commençant par 
' "Mr ", "Mme " ou "Mlle " et qui les efface...
'
With ActiveDocument.ActiveWindow.Selection.Find
          .ClearFormatting
          .Forward = True
          .MatchCase = False
          .Wrap = wdFindContinue
          .Text = "mr "
          .Execute
          Do While .Found = True
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            Selection.Delete Unit:=wdCharacter, Count:=1
            .Execute
          Loop
  End With
 
  With ActiveDocument.ActiveWindow.Selection.Find
          .ClearFormatting
          .Forward = True
          .MatchCase = False
          .Wrap = wdFindContinue
          .Text = "mme "
          .Execute
          Do While .Found = True
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            Selection.Delete Unit:=wdCharacter, Count:=1
            .Execute
          Loop
  End With
 
  With ActiveDocument.ActiveWindow.Selection.Find
          .ClearFormatting
          .Forward = True
          .MatchCase = False
          .Wrap = wdFindContinue
          .Text = "mlle "
          .Execute
          Do While .Found = True
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            Selection.Delete Unit:=wdCharacter, Count:=1
            .Execute
          Loop
  End With
 
  Dim pAra As Paragraph
 
'import Heureux=Oli
 
For Each pAra In ActiveDocument.Paragraphs
   If Len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
     Exit Sub
   End If
Next pAra
 
End Sub

[Heureux-oli]

En fait, j'ai pas eu le temps de tester la macro hier soir, je vais le faire dans la journée.
Probablement que je verrais les problèmes.

[Heureux-oli]

Voila le code corrigé.

Juste deux petites erreurs.

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
Sub boucleFichier()
Dim oFs As New FileSystemObject
Dim oDir As Folder
Dim oFil As File
Dim oDia As FileDialog
Dim stRep As String
Dim oDoc As Document
 
 
 
Set oDia = Application.FileDialog(msoFileDialogFolderPicker)
oDia.Show
stRep = oDia.SelectedItems(1)
Set oDir = oFs.GetFolder(stRep)
For Each oFil In oDir.Files
 
Set oDoc = Documents.Open(stRep & "\" & oFil.Name)
' La boucle de remplacement
Dim pAra As Paragraph
 
For Each pAra In oDoc.Paragraphs
   If Len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
     GoTo ici
   End If
Next pAra
ici:
oDoc.Save
 
oDoc.Close
Set oDoc = Nothing
 
Next oFil
 
Set oFs = Nothing
Set oDir = Nothing
Set oDia = Nothing
 
End Sub

Pour le texte à rechercher, si c'est pour une suppression de paragraphe, c'est probablement pas la solution.
Les recherches et remplacements sont en général utilisés pour un mot.

[BillBoket]

merci Oli ça a l'air de fonctionner.

Par contre il y a un pb: certains fichiers ont des lignes "pseudo-vide" contenant des espaces ou des tabulations, ce qui fait échouer ta fonction.

De plus, il me faut rajouter au script actuel:

-suppression des lignes vides venant après la 1ere ligne non vide
-ajout d'une seule marque de paragraphe (pour espacer)
(cf. exemple en fin de post)

J'ai essayé via la programmation mais sans résultat.
Actuellement je fais tourner un script avec Automator sur Mac qui ouvre un par un les 5000 fichiers et exécute ta macro que j'ai modifiée, ce qui ne fait qu'une partie du boulot, et en plus c'est lent:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 
Dim pAra As Paragraph
 
For Each pAra in ActiveDocument.Paragraphs
   If len(pAra.Range.Text) = 1 Then
      pAra.Range.Delete
   Else
   pAra.Range.Delete
   Exit Sub
     Exit Sub
   End If
Next pAra

Pour faire dans le concret, voici un modèle d'ordonnance source:

{^t^t^t}
{^p}
{^p}
Mme Laurence DUPONT
{^p}
{^p}
MORBILLINUM 30K une dose à jeun le 1er jour
" 200K " 3è "
" MK " 5è "
" XMK " 7è "
SERUM DE YERSIN 9CH lehning 1 dose à jeun le 2è jour, au réveil.
" 12CH " 4è "
" 15CH " 6è "
" 30CH " 8è "
{^p}
{^p}
{^p}

et voilà ce que je veux obtenir :

{^p}
MORBILLINUM 30K une dose à jeun le 1er jour
" 200K " 3è "
" MK " 5è "
" XMK " 7è "
SERUM DE YERSIN 9CH lehning 1 dose à jeun le 2è jour, au réveil.
" 12CH " 4è "
" 15CH " 6è "
" 30CH " 8è "
{^p}
{^p}
{^p}

[BillBoket]

ok je vais essayer d'être plus clair...

Je résume le problème simplement. j'ai besoin d'une macro qui :
- place la sélection en début de fichier
- (A) supprime toutes les lignes vides jusqu'à la première ligne non-vide. Attention: certaines lignes vides comportent des espaces et des tabulations!
- (B) supprime la première ligne non vide.
- (A) supprime toutes les lignes vides jusqu'à la première ligne non-vide.

si vous avez une idée sur les routines (A) et (B), même si ce n'est pas une macro complète, c'est pas grave, je teste!!

[BillBoket]

Voici ma première macro, qui présente l'énorme avantage de ne rien faire du tout!
N'hésitez pas à critiquer, corriger, insister, insulter même si vous voulez, faut qu'ça rentre!

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
 
 
'aller début document
Selection.HomeKey unit:=wdStory, Extend:=wdExtend
 
'tant que sélection active= retour charriot <cr> ou espace ou tabulation
 
While (((Selection.Text) = Chr(13)) Or ((Selection.Text) = Chr(32)) Or ((Selection.Text) = Chr(9)))
 
Select Case (Selection.Text)
 
' si tabulation        
Case (Chr(9))
 
     'méthode Microsoft pour selectionner jusqu'au retour charriot vbCr
     With Selection
     .MoveEndUntil Cset:=vbCr, Count:=wdForward
     .MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
      End With
 
     ' methode personnelle ! pour supprimer la selection et 
     ' aller au début ligne suivante
     Selection.Delete unit:=wdItem
     Selection.MoveDown wdLine, 1, wdMove
     Selection.HomeKey wdLine, wdMove
 
 
Case (Chr(32))
     With Selection
     .MoveEndUntil Cset:=vbCr, Count:=wdForward
     .MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
     Selection.Delete unit:=wdItem
     Selection.MoveDown wdLine, 1, wdMove
     Selection.HomeKey wdLine, wdMove
     End With
 
' recopié depuis ce forum même
Case (Chr(13))
        Selection.Delete unit:=wdCharacter, Count:=1
        Selection.MoveDown wdLine, 1, wdMove
        Selection.HomeKey wdLine, wdMove
 
End Select
 
Wend

[Heureux-oli]

On devrait pouvoir faire le tri sur le premier caractère de la ligne.
Si tu avais un document exemple, pour au moins avoir une idée précise.

[BillBoket]

Salut Oli,

Il y a une ordonnance exemple en pièce jointe .doc
__________________________________________________________
CE QUE L'ON A:

Exemple ordonnance:

Mlle Audrey DUPONT



CHROMIUM METALLICUM 15 CH 2 tubes

3 granules au réveil à commencer si possible 7 jours avant les soins dentaires, finir les tubes

Mais les lignes vides de début (avant Mlle Audrey) peuvent comporter des espaces ou des tabulations (fausses manipulations clavier du médecin)

Pour concrétiser, avec des marques:

<TAB><TAB><TAB><TAB><TAB><CR>
<SPC><SPC><SPC>
<CR>
<CR>
<CR>
<CR>
<CR>
Mlle Audrey DUPONT<CR>
<CR>
<CR>
<CR>
CHROMIUM METALLICUM 15 CH 2 tubes
<CR>
3 granules au réveil à commencer si possible 7 jours avant les soins dentaires, finir les tubes<CR>

__________________________________________________________
CE QUE L'ON VEUT OBTENIR

-> supprimer les lignes vides et la ligne nom_du_patient

<CR>
CHROMIUM METALLICUM 15 CH 2 tubes<CR>
<CR>
3 granules au réveil à commencer si possible 7 jours avant les soins dentaires, finir les tubes

[Heureux-oli]

Essaie avec ce code,

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
Sub testDel()
Dim pAra As Paragraph
 
For Each pAra In ActiveDocument.Paragraphs
Select Case Asc(pAra.Range.Text)
Case 32
pAra.Range.Delete
Case 13
pAra.Range.Delete
Case 9
pAra.Range.Delete
End Select
 
 
Next pAra
 
End Sub

Je vérifie simplement la nature du premier caractère du paragraphe.

[BillBoket]

ça efface des lignes utiles au niveau de la prescription (2e partie du fichier).

Par exemple, il y a la ligne:

Code :

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

"		"	      200K		     3e    ""

et ça me l'a effacé!

Je vais y réfléchir et te tiens au courant.

Merci encore de m'aider!

[BillBoket]

Oli, le bon code semble être celui-ci:

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub supprimer_lignes_vides()
 
While ((Asc(pAra.Range.Text) = 32) Or (Asc(pAra.Range.Text) = 13) Or (Asc(pAra.Range.Text) = 9))
 
pAra.Range.Delete
pAra.Next
 
Wend
 
End Sub

J'ai essayé de reconstruire la macro totale à partir de ton travail précédent, mais il me manque une méthode que j'ai commentée en ROUGE EN GRAS dans le code suivant:
As-tu une idée?

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
Sub boucleFichier()

Dim oFs As New FileSystemObject
Dim oDir As Folder
Dim oFil As File
Dim oDia As FileDialog
Dim stRep As String
Dim oDoc As Document
Dim pAra As Paragraph

Set oDia = Application.FileDialog(msoFileDialogFolderPicker)
oDia.Show
stRep = oDia.SelectedItems(1)
Set oDir = oFs.GetFolder(stRep)
Set oDoc = Documents.Open(stRep & "\" & oFil.Name)
Set pAra = ActiveDocument.Paragraphs(1)

Call supprimer_lignes_vides

If SI LE PREMIER MOT DE LA LIGNE COURANTE CONTIENT "MONSIEUR" OU "MADAME" 
OU "MADEMOISELLE" OU "MR" OU "MME" OU "MLLE" ALORS SUPPRIMER CETTE LIGNE

' Then pAra.Range.Delete ?

' on continue à supprimer les lignes vides
Call supprimer_lignes_vides

' on insere une ligne vide pour espacer
Selection.TypeParagraph

End If

oDoc.Save
 
oDoc.Close

Set oDoc = Nothing
Set oFs = Nothing
Set oDir = Nothing
Set oDia = Nothing
 
End Sub

__________________________________________________________

Sub supprimer_lignes_vides()

While ((Asc(pAra.Range.Text) = 32) Or (Asc(pAra.Range.Text) = 13) Or (Asc(pAra.Range.Text) = 9))

pAra.Range.Delete
pAra.Next

Wend

End Sub

[Heureux-oli]

Mais cette ligne contient une tabulation en début de ligne si bien que je le supprime avec le code que j'ai donné.

Les essais que j'ai faits avec le fichier que tu m'as donnés ont bien fonctionné.

On peut faire le test sur le premier caractère de la ligne.

Code :

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

1
2
 
Select Case Asc(pAra.Range.Characters(1))

[BillBoket]

oui bien sûr mais je me suis aperçu que les 54OO ordonnances ont été faites de manière différentes, et certaines s'écrivent "<TAB> <TAB> Mlle Audrey" d'autres "Mlle Audrey".

Je ne peux pas faire le test sur le premier carac de la ligne

Asc(pAra.Range.Characters(1)

car si c'est un remède commençant par "M" il va me l'effacer.

Donc je dois tester le mot entier et voir si c'est Mr, Monsieur, Mme, Madame, Mlle ou Mademoiselle.

Sinon, le reste a l'air de fonctionner.

Donc: comment tester le premier mot du paragraphe?

[Heureux-oli]

Le premier mot du paragraphe est

Code :

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

pAra.Range.Words (1)