Bouclage et traitement de dossier Word
Bonjour a tous,
Je me permets de réécrire un sujet que je trouvais trop vague.
Tout d'abord je débute depuis 2-3 jours à utiliser VBA pour mon stage, malheureusement mon accès à des documents et à internet est très limité. J'ai donc grandement besoin de conseil pour avancer;
Mon but est d'écrire une macro qui :
- Ouvre un dossier qui contient des documents Words
- Effectuer un bouclage dans ce dossier pour effectuer une tâche unique dans chaque Word une seul fois.
- La tâche est de copier coller un tableau dans une feuille excel. (les tableaux peuvent être réunis sur une seule feuille à la suite ou disposés sur plusieurs.
Mon avancement :
Ce programme marche pour un seul document.
Sub transfer()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim Fichier As String
Fichier = Application.GetOpenFilename("Text Files (*.doc*), *.doc*")
Set WordApp = CreateObject("Word.Application") 'creation session Word
WordApp.Visible = False 'pour que word reste masqué pendant l'opération
Set WordDoc = WordApp.Documents.Open(Fichier) 'ouverture du fichier Word
WordDoc.Tables(5).Range.Copy 'copie du tableau Word
'dans Word chaque tableau est indexé
'ici l'index est à 5 car il correspond au numero du tableau
'qui ne change pas suivant les dossiers stress
Range("A1").Select
ActiveSheet.Paste 'collage des données dans Excel
WordDoc.Close False 'ferme le document Word sans sauvegarde
WordApp.Quit 'ferme l'application Word
End Sub
J'ai réussis à réaliser un bouclage (assez moyen) :
Option Explicit
Sub test()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\Users\NG83466\Documents\SD_STEP6_CERTIF_NATHAN\SD_STEP6_CERTIF_NATHAN"
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
For Each f2 In f1.Files
Set wb = Workbooks.Open(f2)
'MA TACHE A ACCOMPLIR
wb.Close
Next f2
Next f1
End Sub
Ma question est : Comment assembler les deux programmes et comment les optimiser ?
J'ai essayé d'être le plus clair possible, je reste connecté très souvent pour pouvoir suivre le cours de ce sujet.
J'ai vraiment besoin d'aide....
Merci d'avance.
Cordialement
Bonjour,
à tester,
Sub transfer()
Dim Fso As Object, MonRepertoire As String
Dim f1 As Object, f2 As Object, wb As Workbook
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("Word.Application") 'creation session Word
WordApp.Visible = False 'pour que word reste masqué pendant l'opération
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\Users\NG83466\Documents\SD_STEP6_CERTIF_NATHAN\SD_STEP6_CERTIF_NATHAN"
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
For Each f2 In f1.Files
Set WordDoc = WordApp.Documents.Open(f2) 'ouverture du fichier Word
WordDoc.Tables(5).Range.Copy 'copie du tableau Word
Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Select 'à adapter
ActiveSheet.Paste 'collage des données dans Excel
WordDoc.Close False 'ferme le document Word sans sauvegarde
Next f2
Next f1
WordApp.Quit 'ferme l'application Word
End Sub
Bonjour,
Merci pour le programme, je viens de le tester mais j'ai l'impression qu'il n'ouvre pas le répertoire. Mes words sont enregistré en .docm je ne sais pas si cela pose problème.
J'essaye de modifier et je reviens vers vous si je n'y arrive pas
J'ai modifié pour pouvoir sélectionner les fichiers voulus et tester une autre méthode de bouclage.
Je peux sélectionner mes fichiers mais rien ne se passe.
ub transfer()
Dim Fso As Object, MonRepertoire As Variant
Dim f1 As Object, f2 As Object, wb As Workbook
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
MonRepertoire = _
Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docx; *.docm;),*.doc;*.docx", 2, "Choix du dossier d'import", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Cells.ClearContents
Set Target = Range("A1")
For Each FileName In MonRepertoire
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
WordDoc.Tables(2).Range.Copy 'copie du tableau Word
Range("A1").Select 'à adapter
ActiveSheet.Paste 'collage des données dans Excel
WordDoc.Close False 'ferme le document Word sans sauvegarde
Next FileName
WordApp.Quit 'ferme l'application Word
End Sub
J'ai aussi ce programme qui récupère tous les tableaux mais je n'arrive pas à lui faire sélectionner qu'un seul (le 5eme) de chaque doc.
Sub ImportWordTable_testOK()
Dim WordApp As Object, WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo%, tableStart%, tableTot%, Target As Range
arrFileList = _
Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docx; *.docm;),*.doc;*.docx", 2, "Choix du dossier d'import", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Cells.ClearContents
Set Target = Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.Tables.Count
tableTot = WordDoc.Tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "ne contient aucun tableau", vbExclamation, "Importation Tableaux Word"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Entrer le numéro du premier tableau", "Importation Tableaux Word", "1")
End If
For tableStart = 1 To tableTot
With .Tables(tableStart)
.Range.Copy
Target.Activate
ActiveSheet.Paste
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub