bouclage d'un dossier word + traitement

[nathg31]

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

 

[Staple1600]

Bonsoir le fil,

Glané sur le web, aprés un petit G..gling de milieu de soirée.
J'ai francisé la chose et testé sur deux trois documents Word contenant chaquun deux trois tableaux.
Test OK sur Excel 2013

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),*.doc;*.docx", 2, "Choix du dossier d'import", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
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

NB: Pour une meilleure ergonomie, on peut modifier le code pour sélectionner le dossier contenant les fichiers Word.
En l'état, avec cette macro, il faut sélectionner les fichiers (multi-selection possible) puis cliquer sur OK.

 

[nathg31]

Bonjour,
Merci de votre réponse je teste le programme je l'adapte et si tout est ok je clôturerais ce sujet.
Merci.
Cordialement.

NB : Le programme marche effectivement cependant j'ai deux petit soucis :

- Le premier est que j'ai un message (fichier joint). Peut être que c'est dû à la complexité de mes documents.

- Le second est que je souhaiterais prendre que le 5 eme tableau de chaque word.

WordDoc.Tables(5).Range.Copy

j'utilise cette fonction mais je n'arrive pas à l'adapter.

 

[Staple1600]

Bonsoir le fil,

nathg31
Tu indiques le fil comme résolu mais sans publier tes adaptations de mon code VBA.
(Cela aurait pourtant peut-être intéressé la communauté des XLdiens )

Comme indiqué dans le NB de mon précédent message, on peut faire en sorte de ne devoir sélectionner que le dossier contenant les fichiers Word.

Sub ImportWtable2XL() 
Dim FolderName$, MyPath, R As Range 
Dim WordApp As Object, WordDoc As Object 

Set R = Range("A1") 
With Application.FileDialog(msoFileDialogFolderPicker) 
.AllowMultiSelect = False 
.Show 
On Error Resume Next 
FolderName = .SelectedItems(1) 
Err.Clear 
On Error GoTo 0 
End With 
MyPath = FolderName 
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" 
'Boucle sur l'ensemble des fichiers du répertoire sélectionné 
Set WordApp = CreateObject("Word.Application") 
WordApp.Visible = True 
Application.ScreenUpdating = False 
MyFile = Dir(MyPath & "*.doc?") 
Do While Len(MyFile) > 0 
Set WordDoc = WordApp.Documents.Open(MyPath & MyFile, ReadOnly:=True) 
WordDoc.Tables(5).Range.Copy 
ActiveSheet.Paste R 
Set R = Cells(Rows.Count, 1).End(3)(3) 
Application.CutCopyMode = False 
WordApp.ActiveDocument.Close False 
'Et on passe au suivant 
MyFile = Dir() 
Loop 
WordApp.Quit 
Set WordApp = Nothing 
Set WordDoc = Nothing 
End Sub

PS: Lors de mes tests (sur XL2010), la recopie des tableaux dans Excel se fait en gras et ne reproduit pas le format présent dans le tableau Word.
Cela fait la même chose chez vous?

Je vais tester sur Excel 2013 de ce pas.

NB: Pour tester il faut au moins 5 tableaux distincts dans chaque document Word.

EDITION:Résultat du test sur Excel 2013
Le format est reproduit mais les bordures des tableaux recopiés dans Excel sont épaisses alors que ce sont les bordures par défaut dans les documents Word.

 

[nathg31]

Bonjour,
Merci de ton aide je vais remettre le programme je n'ai change que très peu de chose.
Le format n'est pas très important pour mon projet parce que maintenant je vais comparer certaine colonne du tableau pour trouver les occurrences.

Sub IMPORT_TAB()

Dim WordApp As Object, WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo%, tableStart%, tableTot%, Target As Range

Application.ScreenUpdating = False 'Fige l'affichage durant l'execution de la macro pour plus de rapidité
Application.DisplayAlerts = False 'Evite d'avoir des pop-up d'Alertes
    
Feuil3.Select
arrFileList = _
Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docm; *.docx;),*.doc;*.docm", 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
    
        End If
        
            With .Tables(5) 'numéro du tableau voulu
                .Range.Copy
                Target.Activate
                ActiveSheet.Paste
                Set Target = Target.Offset(0, columnOffset:=5)
            End With

        .Close False
    End With
Next FileName
Application.ScreenUpdating = True
Application.DisplayAlerts = True
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Cordialement