import de donnée précise de plusieurs documents .rtf vers une feuille excel.

Question

Bonjour à Tous !

Je dispose de plusieurs fichiers .rtf qui se trouvent tous dans un dossier précis du disque dur et je souhaiterais importer des valeurs texte du tableau vers une feuille excel mais je n'arrive pas à les faire en sorte qu'il y est un retour à ligne dans excel

Pouvez vous me guider svp ?.

Voici le code que j'ai reussi à construire avec differentes recherches :

Sub Bouton2_Clic()


Dim Fichier As String, Direction As String
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim i As Byte
Dim j As Integer
 
Application.ScreenUpdating = False
 
Direction = ThisWorkbook.Path
Fichier = Dir(Direction & "\*.rtf")
Do While Fichier <> "" 'boucle sur tous les fichiers .doc du repertoire
 
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
Set wordDoc = wordApp.Documents.Open(Direction & "" & Fichier) 'ouverture documents word


'transfert de la colone 2 cellul 2
wordDoc.Tables(3).Columns(2).Cells(2).Range.Copy


'collage dans Excel
Range("A2").PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 4
wordDoc.Tables(3).Columns(2).Cells(4).Range.Copy


'collage dans Excel
Range("B2").PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 5
wordDoc.Tables(3).Columns(2).Cells(5).Range.Copy


'collage dans Excel
Range("C2").PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 6
wordDoc.Tables(3).Columns(2).Cells(6).Range.Copy


'collage dans Excel
Range("D2").PasteSpecial xlPasteValues
 
wordDoc.Close False 'fermeture documents word
wordApp.Quit
Set wordDoc = Nothing
Set wordApp = Nothing
Fichier = Dir
 
Loop
End Sub

Par avance Merci

Arnaud

cs_MPi · Answer

Pourrais-tu expliquer ce que tu entends par "retour à la ligne " ?
Où veux-tu que ces retours soient ? à l'intérieur de chaque cellule ? si oui, c'est le format de la cellule que tu dois modifier une fois la copie faite.

De plus, tu devrais mettre ces lignes avant le début de la boucle Do While
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False

Et celles-ci, après le Loop
    wordApp.Quit
    Set wordApp = Nothing

Il ne sert à rien de créer plusieurs fois l'objet Application

MPi²

lesapotresdufunk · Answer

merci pour la réponse :

Retour à la ligne car actuellemnt chaques info de chacun des fichiers rtf se collent toutes sur la meme ligne dans excel. Je souhaierais que chaques info de chaque fichier word creent une ligne dans excel:

J'espere que je suis clair dans mon explication !

Arnaud

lesapotresdufunk · Answer

je voudrais que le fichier excel donne ci : ---- Titre de l'intervention, Date de début, Date de fin, Impact client envisagé, ---- valeur 1er ficher rtf, valeur 1er ficher rtf, valeur 1er ficher rtf, valeur 1er ficher rtf valeur 2me ficher rtf valeur 2me ficher rtf valeur 2me ficher rtf valeur 2me ficher rtf etc.. etc... etc... etc... voici le code tel que vous m'avez demandé de le modifier : Sub Bouton2_Clic() Dim Fichier As String, Direction As String Dim wordApp As Word.Application Dim wordDoc As Word.Document Dim i As Byte Dim j As Integer Application.ScreenUpdating = False Set wordApp = CreateObject("Word.Application") wordApp.Visible = False Direction = ThisWorkbook.Path Fichier = Dir(Direction & "\*.rtf") Do While Fichier <> "" 'boucle sur tous les fichiers .doc du repertoire Set wordDoc = wordApp.Documents.Open(Direction & "" & Fichier) 'ouverture documents word 'transfert de la colone 2 cellul 2 wordDoc.Tables(3).Columns(2).Cells(2).Range.Copy 'collage dans Excel Range("A2").PasteSpecial xlPasteValues 'transfert de la colone 2 cellul 4 wordDoc.Tables(3).Columns(2).Cells(4).Range.Copy 'collage dans Excel Range("B2").PasteSpecial xlPasteValues 'transfert de la colone 2 cellul 5 wordDoc.Tables(3).Columns(2).Cells(5).Range.Copy 'collage dans Excel Range("C2").PasteSpecial xlPasteValues 'transfert de la colone 2 cellul 6 wordDoc.Tables(3).Columns(2).Cells(6).Range.Copy 'collage dans Excel Range("D2").PasteSpecial xlPasteValues wordDoc.Close False 'fermeture documents word Set wordDoc = Nothing Fichier = Dir Loop wordApp.Quit Set wordApp = Nothing End Sub

cs_MPi · Answer

Peut-être en déclarant une variable pour déterminer la ligne sur laquelle copier ?

'......début de code
Ligne = 1


Do While Fichier <> "" 'boucle sur tous les fichiers .doc du repertoire
Ligne = Ligne + 1 

Set wordDoc = wordApp.Documents.Open(Direction & "" & Fichier) 'ouverture documents word



'transfert de la colone 2 cellul 2
wordDoc.Tables(3).Columns(2).Cells(2).Range.Copy



'collage dans Excel
Range("A" & Ligne).PasteSpecial xlPasteValues


 



'transfert de la colone 2 cellul 4
wordDoc.Tables(3).Columns(2).Cells(4).Range.Copy



'collage dans Excel
Range("B

" & Ligne

).PasteSpecial xlPasteValues



'transfert de la colone 2 cellul 5
wordDoc.Tables(3).Columns(2).Cells(5).Range.Copy



'collage dans Excel
Range("C

" & Ligne

).PasteSpecial xlPasteValues



'transfert de la colone 2 cellul 6
wordDoc.Tables(3).Columns(2).Cells(6).Range.Copy



'collage dans Excel
Range("D

" & Ligne

).PasteSpecial xlPasteValues
 
wordDoc.Close False 'fermeture documents word



Set wordDoc = Nothing



Fichier = Dir
 
Loop

'.........fin de code

MPi²

lesapotresdufunk · Answer

Un grand grand merci pour votre aide car tout fonctionne à meveille !

Certain des fichier RTF ne contiennent pas de tableau donc cela arrete le processus.

Pouvez vous me guider pour que le code ne traite pas les fichiers se termiant par _AR.rtf    ?

Encore merci pour votre aide

Arnaud

cs_lermite222 · Answer

bonjour,

If Mid(nomFichier,len(NomFichier)-7,3)="_AR" then
   passe Fichier
End if
A+

lesapotresdufunk · Answer

Bonjour,

Cela indique sub ou fonction non définie :

Sub Bouton2_Clic()


Dim Fichier As String, Direction As String
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim i As Byte
Dim j As Integer
 


Application.ScreenUpdating = False
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
 
Direction = ThisWorkbook.Path
Fichier = Dir(Direction & "\*.rtf")



If Mid(NomFichier, Len(NomFichier) - 7, 3) = "_AR" Then passe Fichier
End If


Ligne = 1
Do While Fichier <> "" 'boucle sur tous les fichiers .doc du repertoire
Ligne = Ligne + 1


Set wordDoc = wordApp.Documents.Open(Direction & "" & Fichier) 'ouverture documents word




'transfert de la colone 2 cellul 2
wordDoc.Tables(3).Columns(2).Cells(2).Range.Copy


'collage dans Excel
Range("A" & Ligne).PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 4
wordDoc.Tables(3).Columns(2).Cells(4).Range.Copy


'collage dans Excel
Range("B" & Ligne).PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 5
wordDoc.Tables(3).Columns(2).Cells(5).Range.Copy


'collage dans Excel
Range("C" & Ligne).PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 6
wordDoc.Tables(3).Columns(2).Cells(6).Range.Copy


'collage dans Excel
Range("D" & Ligne).PasteSpecial xlPasteValues


'transfert de la colone 2 cellul 3
wordDoc.Tables(3).Columns(2).Cells(3).Range.Copy


'collage dans Excel
Range("E" & Ligne).PasteSpecial xlPasteValues
 
wordDoc.Close False 'fermeture documents word


Set wordDoc = Nothing


Fichier = Dir
 
Loop
wordApp.Quit
Set wordApp = Nothing
End Sub

cs_MPi · Answer

Peut-être quelque chose comme Do While Fichier <> "" And Right(Fichier,7) <> "_AR.rtf" Then ' ton code end if Ou encore Do While Fichier <> "" If Right(Fichier,7) <> "_AR.rtf" Then 'ton code End If Loop MPi²

Import de donnée précise de plusieurs documents .rtf vers une feuille excel.

8 réponses

Votre réponse

Discussions similaires