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

Rechercher des sujets similaires à "bouclage traitement dossier word"