Word - Supprimer lignes vides dans 5000 fichiers

Word - Supprimer lignes vides dans 5000 fichiers - VB/VBA/VBS - Programmation

Marsh Posté le 29-04-2008 à 07:48:41    

Bonjour,
j'ai 5000 ordonnances médecin (dans un seul dossier) à remettre en forme pour les intégrer dans un nouveau logiciel.
Voici un exemple d'ordonnance:
 


<TAB><TAB><TAB>
<^p>
<^p>
<^p>
<^p>
<^p>
<^p>
<TAB><TAB><TAB> Madame DUPONT
<^p>
<^p>
<^p>
EUTHYRAL<^p>
un comprimé le matin au petit déjeuner 30 jours renouvelable 2 fois


 
et je voudrai obtenir ceci:
 


<^p>
EUTHYRAL<^p>
un comprimé le matin au petit déjeuner 30 jours renouvelable 2 fois


 
- boucle sur 5000 fichiers:
- boucle pour supprimer toutes les lignes vides (y compris celles contenant des tabulations et des espaces)
- supprimer 1 ligne non-vide
- boucle pour supprimer toutes les lignes vides  
- insérer marque paragraphe
 
Quelqu'un sur le net m'a déjà pondu une macro, mais elle est incomplète. La boucle d'ouverture/enregistrement de fichier marche, mais la boucle de suppression de ligne est incomplète, et elle ne détecte pas les lignes avec tabulations ou espaces.  
 


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
     pAra.Range.Delete
     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


 
Si quelqu'un a une idée, merci d'avance  :love:

Reply

Marsh Posté le 29-04-2008 à 07:48:41   

Reply

Marsh Posté le 29-04-2008 à 11:30:33    

Deux questions :

 

- Quel caractère exactement est le <^p> ?  un simple carriage return ?
- Quel est le format exact de tes ordonnances :  TXT, DOC, autre ?


Message édité par ZeBix le 29-04-2008 à 11:32:16
Reply

Marsh Posté le 29-04-2008 à 16:18:51    

Bonjour,
 
^p = ^013 = retour chariot
 
pour remplacer plusieurs retours consécutifs  faire un rechercher remplacer avec critères spéciaux
 
rechercher : "^013{2;}"
remplacer : "^p"
 

Reply

Marsh Posté le 30-04-2008 à 08:21:57    

salut,
 
<^p> est un simple retour charriot; le format des ordonnances est du .doc
 
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!!
 
Merci d'avance  :love:


Message édité par Bilboket le 30-04-2008 à 08:25:39
Reply

Marsh Posté le 30-04-2008 à 10:50:44    

J'ai pondu ma première macro, qui a l'immense avantage de ne rien faire du tout!!  :pt1cable:  
Help ! :hello:  
 


'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
 


Message édité par Bilboket le 30-04-2008 à 10:52:53
Reply

Marsh Posté le 30-04-2008 à 11:06:42    

Bonjour,
 
Pour supprimer les retours chariots multiple:
 
Selection.HomeKey unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .MatchWildcards = true    
    .Text = "[^032^009]{1;}^013"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
End With
Selection.HomeKey unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .MatchWildcards = true    
    .Text = "[^013]{2;}3"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
End With

Reply

Marsh Posté le 30-04-2008 à 15:33:25    

super pyrof! Merci!
la première routine marche, il supprime bien les tabs et les espaces!
Génial! (3 jours que je suis dessus) :wahoo:  
C'est un premier point.
 
Par contre, la seconde ne marche pas. Il ne trouve pas l'expression "[^013]{2;}3" dans le fichier, donc ne supprime pas les <CR>. Une erreur?
 
Ensuite, je voudrais limiter la recherche à la portion de début du document, non à la totalité :
 
- supprimer les premières lignes blanches composées de <SPC>, <TAB> ou <CR>
- supprimer la première ligne non-vide (nom_du_patient)
- supprimer les lignes blanches suivantes composées de <CR>, jusqu'à la première ligne de texte (mais pas après)
 
Exemple:
 
Au départ on a :

<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>


 
A l'arrivée, on veut:
 

<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


Message édité par Bilboket le 30-04-2008 à 15:33:54
Reply

Marsh Posté le 30-04-2008 à 15:37:14    

Désolé j'ai fait une erreur de frappe
 
"[^013]{2;}" au lieu de "[^013]{2;}3"
 
Pour le reste, je n'ai pas trop de temps je verrais

Reply

Marsh Posté le 01-05-2008 à 12:50:52    

J'ai écrit ce code à partir de différentes parties qu'on m'a données:
Il me manque une methode (au milieu, en rouge en gras).  
Si quelqu'un a une idée...
 

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


 
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

Reply

Marsh Posté le 02-05-2008 à 11:15:26    

Bonjour,
 
Voici une méthode :
 
Sub Macro6()
traite "monsieur"
traite "madame"
traite "mademoiselle"
End Sub
 
Private Sub traite(mot)
Selection.HomeKey unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .MatchWildcards = False
    .Text = Chr(13) & mot
    .Execute
End With
While Selection.Find.Found
    Selection.MoveRight
    Selection.MoveStartUntil cset:=Chr(12) & Chr(13), Count:=wdBackward
    Selection.MoveEndUntil cset:=Chr(13), Count:=wdForward
    Selection.DeleteSelection.Find.Execute
Wend
End Sub

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed