Petit jeu de récupération et de compilation entre word et excel

[gyam]

Bonjour,

Voici ce que j'essaye de faire:
J'ai différents fichiers word, classés par date et qui comportent tous plusieurs feuilles excel en objet inséré. Suis un classeur excel, qui doit regrouper les informations, jour par jour, d'une seule de ces feuilles.

L'idée serait d'ouvrir un à un les fichiers word, d'y rechercher la feuille en question puis de copier et de coller dans le classeur.

Jusqu'à présent, ma macro propose de choisir un répertoire (celui de l'année) puis extrait le nom de tous les fichiers word, triés par mois. Pour vous donner une idée de la tâche, mes archives commencent en 2002...en gros 4200 fichiers word à ouvrir!

Ensuite, j'appelle extract:

Sub Extract(fichier As String)

Dim WordApp As Word.Application
Dim WordDoc As Word.Document

Set WordApp = CreateObject("word.application")
    wWrdApp.Visible = False
    Set WordDoc = WordApp.Documents.Open(fichier)

'?????????????????????????

    WordDoc.Close
    WordApp.Quit
End Sub

et c'est là où ça coince. Il me semble comprendre qu'il me faille passer par OLEFormat et autres fonctions sur les objets, mais je n'y connais rien dans le domaine et la doc est ardue.

Auriez vous une piste à me proposer pour trouver la bonne feuille excel insérée (elle est systématiquement précédée du titre "TIME ANALYSIS" suivi d'un retour chariot et d'un sous titre, variable celui là...), de l'ouvrir pour y copier la deuxième colonne et de coller dans excel?

 

[Staple1600]

Re : Petit jeu de récupération et de compilation entre word et excel

Bonjour à tous


Petite macro pour peut-être petite inspiration pour le petit jeu
(test presque OK car la copie est une image et j'arrive pas à faire autrement)
Dans un document WORD, insérer un objet Excel et y saisir quelques données puis lancer la macro.
(Excel doit être fermé, c'est mieux)

Sub a()
Dim oXLS As Object
Dim oDoc As Document
Set oDoc = ActiveDocument
For i = 1 To oDoc.InlineShapes.Count
If oDoc.InlineShapes(i).Type = wdInlineShapeEmbeddedOLEObject Then
If Left(oDoc.InlineShapes(i).OLEFormat.ProgID, 11) = "Excel.Sheet" Then
oDoc.InlineShapes(i).OLEFormat.DoVerb 2
oDoc.InlineShapes(i).OLEFormat.Object.Parent.ActiveWindow.VisibleRange.Copy
Set oXLS = CreateObject("Excel.Application")
    oXLS.Visible = True
    oXLS.Workbooks.Add
    oXLS.worksheets(1).PasteSpecial _
    Format:="Objet Microsoft Excel 97-2003 Worksheet", _
    Link:=False, DisplayAsIcon:=False
End If
End If
Next i
End Sub

RESULTAT: Dans un nouveau classeur, on a bien la copie (mais en image) de l'objet Excel du document Word.

 

[gyam]

Re : Petit jeu de récupération et de compilation entre word et excel

Bonjour,

Merci pour l'aide. J'ai essayé de triturer le code mais comme il doit être inséré dans le fichier word, c'est moins pratique (en gros, il me faut l'insérer dans les 4000 fichiers). J'essaye de voir si l'action peut être pilotée depuis le classeur excel qui va recueillir les données.
Par contre, le fait d'avoir une instance excel (le classeur principal) qui ouvre une instance word puis va chercher un objet excel à l'intérieur, donc à priori une autre instance, ça risque pas de faire foirer le code?

 

[Staple1600]

Re : Petit jeu de récupération et de compilation entre word et excel

Re

Mon code VBA n'est que ceci comme précisé

Petite macro pour peut-être petite inspiration pour le petit jeu

Si on reprend la problèmatique

L'idée serait d'ouvrir un à un les fichiers word, d'y rechercher la feuille en question puis de copier et de coller dans le classeur.

1) Le code de la macro devrait être dans le fichier Excel
2) Une boucle ouvre les fichiers Word
(ce que ne fait ps mon code puisque ce n'est qu'un testt qui fonctionne sur le document Word actif)
Donc il faudrait adapter et pour cela: identifier le bon OLEObject
3) Trouver pourquoi la copie se fait au format image.

Question: As-tu testé mon code sur un document Word en suivant les indications de mon précédent message ?
Cela fonctionne, non ? La copie se fait dans Excel.

A la relecture, il vaut mieux l'écrire ainsi:

Sub b()
Dim oXLS As Object
Dim oDoc As Document
Dim i
Set oDoc = ActiveDocument
Set oXLS = CreateObject("Excel.Application")
    oXLS.Visible = True
    oXLS.Workbooks.Add

For i = 1 To oDoc.InlineShapes.Count
If oDoc.InlineShapes(i).Type = wdInlineShapeEmbeddedOLEObject Then
If Left(oDoc.InlineShapes(i).OLEFormat.ProgID, 11) = "Excel.Sheet" Then
oDoc.InlineShapes(i).OLEFormat.DoVerb 2
oDoc.InlineShapes(i).OLEFormat.Object.Parent.ActiveWindow.VisibleRange.Copy
'oXLS.worksheets(1).PasteSpecial Format:="Texte Unicode", Link:=False, DisplayAsIcon:=False 'Pas OK
oXLS.Worksheets(1).Range("A1").PasteSpecial Format:="Objet Microsoft Excel 97-2003 Worksheet", _
    Link:=False, DisplayAsIcon:=False
End If
End If
Next i
End Sub

 

[gyam]

Re : Petit jeu de récupération et de compilation entre word et excel

Bonjour,

Merci pour la piste. Voici le code (sale et peu optimisé pour l'instant):

Option Explicit
Private Rep As String
Private Wbk As String
Private WordApp As Word.Application
Private WordDoc As Word.Document
Private u As Integer
Private RefRow As Long
Private PasteEntete As Boolean
Private Fso As Scripting.FileSystemObject
Private SourceFolder As Scripting.Folder
Private SubFolder As Scripting.Folder
Private FileItem As Scripting.File

Sub Import()
    Dim Response
    Dim Repertoire As FileDialog
    Dim Dossier As String

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Wbk = ThisWorkbook.Name
    Dossier = ThisWorkbook.Path & "\DPR"
    'Traitement des fichiers
    ListeSousDossier Dossier
    MsgBox ("Importation terminée!")
End Sub

Sub ListeSousDossier(Repertoire As String)
    'Appel récursif pour créer les onglets et lister les fichier dans les sous-répertoires
    For i = Val(Cells(10, 5)) To Year(Now())
        Rep = i
        Sheets.Add.Name = Rep
        Sheets(Rep).Tab.ColorIndex = 4
        Sheets(Rep).Move After:=Worksheets(Worksheets.Count)
        PasteEntete = False
        ListeFichiers (Repertoire & "\" & Rep)
    Next i
End Sub

Sub ListeFichiers(Repertoire As String)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
    
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        RefRow = Val(Left(SubFolder.Name, InStr(1, SubFolder.Name, "-") - 1) - 1) * 18
        If PasteEntete = False Then
            Sheets("Commande").Select
            Range("M3:M15").Select
            Selection.Copy
            Sheets(Rep).Select
            Range("A5").Offset(RefRow, 0).Select
            ActiveSheet.Paste
            Columns("A:A").AutoFit
            Range("A5").Offset(RefRow - 3, 0).Value = Mid(SubFolder.Name, InStr(1, SubFolder.Name, "-") + 1)
            PasteEntete = True
        End If
        If FileItem.Type = "Microsoft Word Document" Then
            'Extrait le jour du nom de fichier (date type xx-xx-xx ou xx-janv-xx)
            Range("A5").Offset(RefRow - 3, Left(FindDate(FileItem.Name), 2)).Value = Left(FindDate(FileItem.Name), 2)
            'Extrait la deuxième colonne du tableau
            Extract FileItem.Path
            'Ajoute un hyperlien vers le fichier
            Sheets(Rep).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A5").Offset(RefRow - 3, Left(FindDate(FileItem.Name), 2)), _
                Address:=FileItem.ParentFolder & "\" & FileItem.Name
        End If
    Next FileItem
    For Each SubFolder In SourceFolder.SubFolders
        PasteEntete = False
        ListeFichiers SubFolder.Path
    Next SubFolder

    Set SubFolder = Nothing
    Set SourceFolder = Nothing
    Set Fso = Nothing
End Sub

Function FindDate(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d{2}\-.{2,9}\-\d{2}"
        If .test(txt) Then FindDate = .Execute(txt)(0)
    End With
End Function

Sub Extract(fichier As String)
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(fichier, ReadOnly:=True)
    u = WordDoc.InlineShapes.Count
        If WordDoc.InlineShapes(u).Type = wdInlineShapeEmbeddedOLEObject Then
            If Left(WordDoc.InlineShapes(u).OLEFormat.progID, 11) = "Excel.Sheet" Then
                
                WordDoc.InlineShapes(u).OLEFormat.DoVerb (wdOLEVerbOpen)
                WordDoc.InlineShapes(u).OLEFormat.Object.Parent.ActiveWindow.VisibleRange.Offset(0, 1).Copy
                
                Windows(Wbk).Activate
                Sheets(Rep).Select
                Range("A5").Offset(RefRow - 2, Left(FindDate(FileItem.Name), 2)).Select
                ActiveSheet.Paste
            End If
        Else
            MsgBox ("Time Analysis non trouvé." & Chr(10) & fichier)
            Range("A5").Offset(RefRow - 2, Left(FindDate(FileItem.Name), 2)).Value = "XX"
        End If
    WordDoc.Close SaveChanges:=False
    WordApp.Quit
End Sub

J'arrive donc à sélectionner la deuxieme colonne de la feuille excel et à la coller là où je le souhaite (macro Extract).
Il reste quelques bugs:
- Apparemment, InlineShapes renvois les feuilles excel insérées par ordre de création et non selon leur position dans le document word, ce qui m'embête car celle qui m'intéresse est systématiquement la dernière du document... Comment ne sélectionner que celle là (soit relativement à sa position dans le document complet, soit en recherchant le titre "Time Analysis" - qui correspond à son titre - et en sélectionnant la feuille insérée qui suit?)
- Le fait de créer et de fermer à chaque extraction une instance word ralentit considérablement l'exécution. Mais si je n'effectue pas cette opération, je me retrouve avec énormément d'instances ouvertes dans le task manager et au bout d'un moment, ralentissement puis plantage, normal.
- Une erreur 5941 se produit au bout de quelques itérations...?

Pour fignoler, je cherche à ne pas passer par 'VisibleRange' lors de la copie de la plage de donnée qui m'intéresse mais une simple déclaration du style Range("B3:B13") à la place ne fonctionne pas.